lwall@netlabs.com (Larry Wall) (04/18/91)
Submitted-by: Larry Wall <lwall@netlabs.com>
Posting-number: Volume 18, Issue 42
Archive-name: perl/part24
[There are 36 kits for perl version 4.0.]
#! /bin/sh
# Make a new directory for the perl sources, cd to it, and run kits 1
# thru 36 through sh. When all 36 kits have been run, read README.
echo "This is perl 4.0 kit 24 (of 36). If kit 24 is complete, the line"
echo '"'"End of kit 24 (of 36)"'" will echo at the end.'
echo ""
export PATH || (echo "You didn't use sh, you clunch." ; kill $$)
mkdir msdos x2p 2>/dev/null
echo Extracting x2p/a2py.c
sed >x2p/a2py.c <<'!STUFFY!FUNK!' -e 's/X//'
X/* $Header: a2py.c,v 4.0 91/03/20 01:57:26 lwall Locked $
X *
X * Copyright (c) 1989, Larry Wall
X *
X * You may distribute under the terms of the GNU General Public License
X * as specified in the README file that comes with the perl 3.0 kit.
X *
X * $Log: a2py.c,v $
X * Revision 4.0 91/03/20 01:57:26 lwall
X * 4.0 baseline.
X *
X */
X
X#ifdef MSDOS
X#include "../patchlev.h"
X#endif
X#include "util.h"
Xchar *index();
X
Xchar *filename;
Xchar *myname;
X
Xint checkers = 0;
XSTR *walk();
X
X#ifdef MSDOS
Xusage()
X{
X printf("\nThis is the AWK to PERL translator, version 3.0, patchlevel %d\n", PATCHLEVEL);
X printf("\nUsage: %s [-D<number>] [-F<char>] [-n<fieldlist>] [-<number>] filename\n", myname);
X printf("\n -D<number> sets debugging flags."
X "\n -F<character> the awk script to translate is always invoked with"
X "\n this -F switch."
X "\n -n<fieldlist> specifies the names of the input fields if input does"
X "\n not have to be split into an array."
X "\n -<number> causes a2p to assume that input will always have that"
X "\n many fields.\n");
X exit(1);
X}
X#endif
Xmain(argc,argv,env)
Xregister int argc;
Xregister char **argv;
Xregister char **env;
X{
X register STR *str;
X register char *s;
X int i;
X STR *tmpstr;
X
X myname = argv[0];
X linestr = str_new(80);
X str = str_new(0); /* first used for -I flags */
X for (argc--,argv++; argc; argc--,argv++) {
X if (argv[0][0] != '-' || !argv[0][1])
X break;
X reswitch:
X switch (argv[0][1]) {
X#ifdef DEBUGGING
X case 'D':
X debug = atoi(argv[0]+2);
X#ifdef YYDEBUG
X yydebug = (debug & 1);
X#endif
X break;
X#endif
X case '0': case '1': case '2': case '3': case '4':
X case '5': case '6': case '7': case '8': case '9':
X maxfld = atoi(argv[0]+1);
X absmaxfld = TRUE;
X break;
X case 'F':
X fswitch = argv[0][2];
X break;
X case 'n':
X namelist = savestr(argv[0]+2);
X break;
X case '-':
X argc--,argv++;
X goto switch_end;
X case 0:
X break;
X default:
X fatal("Unrecognized switch: %s\n",argv[0]);
X#ifdef MSDOS
X usage();
X#endif
X }
X }
X switch_end:
X
X /* open script */
X
X if (argv[0] == Nullch) {
X#ifdef MSDOS
X if ( isatty(fileno(stdin)) )
X usage();
X#endif
X argv[0] = "-";
X }
X filename = savestr(argv[0]);
X
X filename = savestr(argv[0]);
X if (strEQ(filename,"-"))
X argv[0] = "";
X if (!*argv[0])
X rsfp = stdin;
X else
X rsfp = fopen(argv[0],"r");
X if (rsfp == Nullfp)
X fatal("Awk script \"%s\" doesn't seem to exist.\n",filename);
X
X /* init tokener */
X
X bufptr = str_get(linestr);
X symtab = hnew();
X curarghash = hnew();
X
X /* now parse the report spec */
X
X if (yyparse())
X fatal("Translation aborted due to syntax errors.\n");
X
X#ifdef DEBUGGING
X if (debug & 2) {
X int type, len;
X
X for (i=1; i<mop;) {
X type = ops[i].ival;
X len = type >> 8;
X type &= 255;
X printf("%d\t%d\t%d\t%-10s",i++,type,len,opname[type]);
X if (type == OSTRING)
X printf("\t\"%s\"\n",ops[i].cval),i++;
X else {
X while (len--) {
X printf("\t%d",ops[i].ival),i++;
X }
X putchar('\n');
X }
X }
X }
X if (debug & 8)
X dump(root);
X#endif
X
X /* first pass to look for numeric variables */
X
X prewalk(0,0,root,&i);
X
X /* second pass to produce new program */
X
X tmpstr = walk(0,0,root,&i,P_MIN);
X str = str_make("#!");
X str_cat(str, BIN);
X str_cat(str, "/perl\neval \"exec ");
X str_cat(str, BIN);
X str_cat(str, "/perl -S $0 $*\"\n\
X if $running_under_some_shell;\n\
X # this emulates #! processing on NIH machines.\n\
X # (remove #! line above if indigestible)\n\n");
X str_cat(str,
X "eval '$'.$1.'$2;' while $ARGV[0] =~ /^([A-Za-z_]+=)(.*)/ && shift;\n");
X str_cat(str,
X " # process any FOO=bar switches\n\n");
X if (do_opens && opens) {
X str_scat(str,opens);
X str_free(opens);
X str_cat(str,"\n");
X }
X str_scat(str,tmpstr);
X str_free(tmpstr);
X#ifdef DEBUGGING
X if (!(debug & 16))
X#endif
X fixup(str);
X putlines(str);
X if (checkers) {
X fprintf(stderr,
X "Please check my work on the %d line%s I've marked with \"#???\".\n",
X checkers, checkers == 1 ? "" : "s" );
X fprintf(stderr,
X "The operation I've selected may be wrong for the operand types.\n");
X }
X exit(0);
X}
X
X#define RETURN(retval) return (bufptr = s,retval)
X#define XTERM(retval) return (expectterm = TRUE,bufptr = s,retval)
X#define XOP(retval) return (expectterm = FALSE,bufptr = s,retval)
X#define ID(x) return (yylval=string(x,0),expectterm = FALSE,bufptr = s,idtype)
X
Xint idtype;
X
Xyylex()
X{
X register char *s = bufptr;
X register char *d;
X register int tmp;
X
X retry:
X#ifdef YYDEBUG
X if (yydebug)
X if (index(s,'\n'))
X fprintf(stderr,"Tokener at %s",s);
X else
X fprintf(stderr,"Tokener at %s\n",s);
X#endif
X switch (*s) {
X default:
X fprintf(stderr,
X "Unrecognized character %c in file %s line %d--ignoring.\n",
X *s++,filename,line);
X goto retry;
X case '\\':
X case 0:
X s = str_get(linestr);
X *s = '\0';
X if (!rsfp)
X RETURN(0);
X line++;
X if ((s = str_gets(linestr, rsfp)) == Nullch) {
X if (rsfp != stdin)
X fclose(rsfp);
X rsfp = Nullfp;
X s = str_get(linestr);
X RETURN(0);
X }
X goto retry;
X case ' ': case '\t':
X s++;
X goto retry;
X case '\n':
X *s = '\0';
X XTERM(NEWLINE);
X case '#':
X yylval = string(s,0);
X *s = '\0';
X XTERM(COMMENT);
X case ';':
X tmp = *s++;
X if (*s == '\n') {
X s++;
X XTERM(SEMINEW);
X }
X XTERM(tmp);
X case '(':
X tmp = *s++;
X XTERM(tmp);
X case '{':
X case '[':
X case ')':
X case ']':
X case '?':
X case ':':
X tmp = *s++;
X XOP(tmp);
X case 127:
X s++;
X XTERM('}');
X case '}':
X for (d = s + 1; isspace(*d); d++) ;
X if (!*d)
X s = d - 1;
X *s = 127;
X XTERM(';');
X case ',':
X tmp = *s++;
X XTERM(tmp);
X case '~':
X s++;
X yylval = string("~",1);
X XTERM(MATCHOP);
X case '+':
X case '-':
X if (s[1] == *s) {
X s++;
X if (*s++ == '+')
X XTERM(INCR);
X else
X XTERM(DECR);
X }
X /* FALL THROUGH */
X case '*':
X case '%':
X case '^':
X tmp = *s++;
X if (*s == '=') {
X if (tmp == '^')
X yylval = string("**=",3);
X else
X yylval = string(s-1,2);
X s++;
X XTERM(ASGNOP);
X }
X XTERM(tmp);
X case '&':
X s++;
X tmp = *s++;
X if (tmp == '&')
X XTERM(ANDAND);
X s--;
X XTERM('&');
X case '|':
X s++;
X tmp = *s++;
X if (tmp == '|')
X XTERM(OROR);
X s--;
X while (*s == ' ' || *s == '\t')
X s++;
X if (strnEQ(s,"getline",7))
X XTERM('p');
X else
X XTERM('|');
X case '=':
X s++;
X tmp = *s++;
X if (tmp == '=') {
X yylval = string("==",2);
X XTERM(RELOP);
X }
X s--;
X yylval = string("=",1);
X XTERM(ASGNOP);
X case '!':
X s++;
X tmp = *s++;
X if (tmp == '=') {
X yylval = string("!=",2);
X XTERM(RELOP);
X }
X if (tmp == '~') {
X yylval = string("!~",2);
X XTERM(MATCHOP);
X }
X s--;
X XTERM(NOT);
X case '<':
X s++;
X tmp = *s++;
X if (tmp == '=') {
X yylval = string("<=",2);
X XTERM(RELOP);
X }
X s--;
X XTERM('<');
X case '>':
X s++;
X tmp = *s++;
X if (tmp == '>') {
X yylval = string(">>",2);
X XTERM(GRGR);
X }
X if (tmp == '=') {
X yylval = string(">=",2);
X XTERM(RELOP);
X }
X s--;
X XTERM('>');
X
X#define SNARFWORD \
X d = tokenbuf; \
X while (isalpha(*s) || isdigit(*s) || *s == '_') \
X *d++ = *s++; \
X *d = '\0'; \
X d = tokenbuf; \
X if (*s == '(') \
X idtype = USERFUN; \
X else \
X idtype = VAR;
X
X case '$':
X s++;
X if (*s == '0') {
X s++;
X do_chop = TRUE;
X need_entire = TRUE;
X idtype = VAR;
X ID("0");
X }
X do_split = TRUE;
X if (isdigit(*s)) {
X for (d = s; isdigit(*s); s++) ;
X yylval = string(d,s-d);
X tmp = atoi(d);
X if (tmp > maxfld)
X maxfld = tmp;
X XOP(FIELD);
X }
X split_to_array = set_array_base = TRUE;
X XOP(VFIELD);
X
X case '/': /* may either be division or pattern */
X if (expectterm) {
X s = scanpat(s);
X XTERM(REGEX);
X }
X tmp = *s++;
X if (*s == '=') {
X yylval = string("/=",2);
X s++;
X XTERM(ASGNOP);
X }
X XTERM(tmp);
X
X case '0': case '1': case '2': case '3': case '4':
X case '5': case '6': case '7': case '8': case '9': case '.':
X s = scannum(s);
X XOP(NUMBER);
X case '"':
X s++;
X s = cpy2(tokenbuf,s,s[-1]);
X if (!*s)
X fatal("String not terminated:\n%s",str_get(linestr));
X s++;
X yylval = string(tokenbuf,0);
X XOP(STRING);
X
X case 'a': case 'A':
X SNARFWORD;
X if (strEQ(d,"ARGC"))
X set_array_base = TRUE;
X if (strEQ(d,"ARGV")) {
X yylval=numary(string("ARGV",0));
X XOP(VAR);
X }
X if (strEQ(d,"atan2")) {
X yylval = OATAN2;
X XTERM(FUNN);
X }
X ID(d);
X case 'b': case 'B':
X SNARFWORD;
X if (strEQ(d,"break"))
X XTERM(BREAK);
X if (strEQ(d,"BEGIN"))
X XTERM(BEGIN);
X ID(d);
X case 'c': case 'C':
X SNARFWORD;
X if (strEQ(d,"continue"))
X XTERM(CONTINUE);
X if (strEQ(d,"cos")) {
X yylval = OCOS;
X XTERM(FUN1);
X }
X if (strEQ(d,"close")) {
X do_fancy_opens = 1;
X yylval = OCLOSE;
X XTERM(FUN1);
X }
X if (strEQ(d,"chdir"))
X *d = toupper(*d);
X else if (strEQ(d,"crypt"))
X *d = toupper(*d);
X else if (strEQ(d,"chop"))
X *d = toupper(*d);
X else if (strEQ(d,"chmod"))
X *d = toupper(*d);
X else if (strEQ(d,"chown"))
X *d = toupper(*d);
X ID(d);
X case 'd': case 'D':
X SNARFWORD;
X if (strEQ(d,"do"))
X XTERM(DO);
X if (strEQ(d,"delete"))
X XTERM(DELETE);
X if (strEQ(d,"die"))
X *d = toupper(*d);
X ID(d);
X case 'e': case 'E':
X SNARFWORD;
X if (strEQ(d,"END"))
X XTERM(END);
X if (strEQ(d,"else"))
X XTERM(ELSE);
X if (strEQ(d,"exit")) {
X saw_line_op = TRUE;
X XTERM(EXIT);
X }
X if (strEQ(d,"exp")) {
X yylval = OEXP;
X XTERM(FUN1);
X }
X if (strEQ(d,"elsif"))
X *d = toupper(*d);
X else if (strEQ(d,"eq"))
X *d = toupper(*d);
X else if (strEQ(d,"eval"))
X *d = toupper(*d);
X else if (strEQ(d,"eof"))
X *d = toupper(*d);
X else if (strEQ(d,"each"))
X *d = toupper(*d);
X else if (strEQ(d,"exec"))
X *d = toupper(*d);
X ID(d);
X case 'f': case 'F':
X SNARFWORD;
X if (strEQ(d,"FS")) {
X saw_FS++;
X if (saw_FS == 1 && in_begin) {
X for (d = s; *d && isspace(*d); d++) ;
X if (*d == '=') {
X for (d++; *d && isspace(*d); d++) ;
X if (*d == '"' && d[2] == '"')
X const_FS = d[1];
X }
X }
X ID(tokenbuf);
X }
X if (strEQ(d,"for"))
X XTERM(FOR);
X else if (strEQ(d,"function"))
X XTERM(FUNCTION);
X if (strEQ(d,"FILENAME"))
X d = "ARGV";
X if (strEQ(d,"foreach"))
X *d = toupper(*d);
X else if (strEQ(d,"format"))
X *d = toupper(*d);
X else if (strEQ(d,"fork"))
X *d = toupper(*d);
X else if (strEQ(d,"fh"))
X *d = toupper(*d);
X ID(d);
X case 'g': case 'G':
X SNARFWORD;
X if (strEQ(d,"getline"))
X XTERM(GETLINE);
X if (strEQ(d,"gsub"))
X XTERM(GSUB);
X if (strEQ(d,"ge"))
X *d = toupper(*d);
X else if (strEQ(d,"gt"))
X *d = toupper(*d);
X else if (strEQ(d,"goto"))
X *d = toupper(*d);
X else if (strEQ(d,"gmtime"))
X *d = toupper(*d);
X ID(d);
X case 'h': case 'H':
X SNARFWORD;
X if (strEQ(d,"hex"))
X *d = toupper(*d);
X ID(d);
X case 'i': case 'I':
X SNARFWORD;
X if (strEQ(d,"if"))
X XTERM(IF);
X if (strEQ(d,"in"))
X XTERM(IN);
X if (strEQ(d,"index")) {
X set_array_base = TRUE;
X XTERM(INDEX);
X }
X if (strEQ(d,"int")) {
X yylval = OINT;
X XTERM(FUN1);
X }
X ID(d);
X case 'j': case 'J':
X SNARFWORD;
X if (strEQ(d,"join"))
X *d = toupper(*d);
X ID(d);
X case 'k': case 'K':
X SNARFWORD;
X if (strEQ(d,"keys"))
X *d = toupper(*d);
X else if (strEQ(d,"kill"))
X *d = toupper(*d);
X ID(d);
X case 'l': case 'L':
X SNARFWORD;
X if (strEQ(d,"length")) {
X yylval = OLENGTH;
X XTERM(FUN1);
X }
X if (strEQ(d,"log")) {
X yylval = OLOG;
X XTERM(FUN1);
X }
X if (strEQ(d,"last"))
X *d = toupper(*d);
X else if (strEQ(d,"local"))
X *d = toupper(*d);
X else if (strEQ(d,"lt"))
X *d = toupper(*d);
X else if (strEQ(d,"le"))
X *d = toupper(*d);
X else if (strEQ(d,"locatime"))
X *d = toupper(*d);
X else if (strEQ(d,"link"))
X *d = toupper(*d);
X ID(d);
X case 'm': case 'M':
X SNARFWORD;
X if (strEQ(d,"match")) {
X set_array_base = TRUE;
X XTERM(MATCH);
X }
X if (strEQ(d,"m"))
X *d = toupper(*d);
X ID(d);
X case 'n': case 'N':
X SNARFWORD;
X if (strEQ(d,"NF"))
X do_chop = do_split = split_to_array = set_array_base = TRUE;
X if (strEQ(d,"next")) {
X saw_line_op = TRUE;
X XTERM(NEXT);
X }
X if (strEQ(d,"ne"))
X *d = toupper(*d);
X ID(d);
X case 'o': case 'O':
X SNARFWORD;
X if (strEQ(d,"ORS")) {
X saw_ORS = TRUE;
X d = "\\";
X }
X if (strEQ(d,"OFS")) {
X saw_OFS = TRUE;
X d = ",";
X }
X if (strEQ(d,"OFMT")) {
X d = "#";
X }
X if (strEQ(d,"open"))
X *d = toupper(*d);
X else if (strEQ(d,"ord"))
X *d = toupper(*d);
X else if (strEQ(d,"oct"))
X *d = toupper(*d);
X ID(d);
X case 'p': case 'P':
X SNARFWORD;
X if (strEQ(d,"print")) {
X XTERM(PRINT);
X }
X if (strEQ(d,"printf")) {
X XTERM(PRINTF);
X }
X if (strEQ(d,"push"))
X *d = toupper(*d);
X else if (strEQ(d,"pop"))
X *d = toupper(*d);
X ID(d);
X case 'q': case 'Q':
X SNARFWORD;
X ID(d);
X case 'r': case 'R':
X SNARFWORD;
X if (strEQ(d,"RS")) {
X d = "/";
X saw_RS = TRUE;
X }
X if (strEQ(d,"rand")) {
X yylval = ORAND;
X XTERM(FUN1);
X }
X if (strEQ(d,"return"))
X XTERM(RET);
X if (strEQ(d,"reset"))
X *d = toupper(*d);
X else if (strEQ(d,"redo"))
X *d = toupper(*d);
X else if (strEQ(d,"rename"))
X *d = toupper(*d);
X ID(d);
X case 's': case 'S':
X SNARFWORD;
X if (strEQ(d,"split")) {
X set_array_base = TRUE;
X XOP(SPLIT);
X }
X if (strEQ(d,"substr")) {
X set_array_base = TRUE;
X XTERM(SUBSTR);
X }
X if (strEQ(d,"sub"))
X XTERM(SUB);
X if (strEQ(d,"sprintf"))
X XTERM(SPRINTF);
X if (strEQ(d,"sqrt")) {
X yylval = OSQRT;
X XTERM(FUN1);
X }
X if (strEQ(d,"SUBSEP")) {
X d = ";";
X }
X if (strEQ(d,"sin")) {
X yylval = OSIN;
X XTERM(FUN1);
X }
X if (strEQ(d,"srand")) {
X yylval = OSRAND;
X XTERM(FUN1);
X }
X if (strEQ(d,"system")) {
X yylval = OSYSTEM;
X XTERM(FUN1);
X }
X if (strEQ(d,"s"))
X *d = toupper(*d);
X else if (strEQ(d,"shift"))
X *d = toupper(*d);
X else if (strEQ(d,"select"))
X *d = toupper(*d);
X else if (strEQ(d,"seek"))
X *d = toupper(*d);
X else if (strEQ(d,"stat"))
X *d = toupper(*d);
X else if (strEQ(d,"study"))
X *d = toupper(*d);
X else if (strEQ(d,"sleep"))
X *d = toupper(*d);
X else if (strEQ(d,"symlink"))
X *d = toupper(*d);
X else if (strEQ(d,"sort"))
X *d = toupper(*d);
X ID(d);
X case 't': case 'T':
X SNARFWORD;
X if (strEQ(d,"tr"))
X *d = toupper(*d);
X else if (strEQ(d,"tell"))
X *d = toupper(*d);
X else if (strEQ(d,"time"))
X *d = toupper(*d);
X else if (strEQ(d,"times"))
X *d = toupper(*d);
X ID(d);
X case 'u': case 'U':
X SNARFWORD;
X if (strEQ(d,"until"))
X *d = toupper(*d);
X else if (strEQ(d,"unless"))
X *d = toupper(*d);
X else if (strEQ(d,"umask"))
X *d = toupper(*d);
X else if (strEQ(d,"unshift"))
X *d = toupper(*d);
X else if (strEQ(d,"unlink"))
X *d = toupper(*d);
X else if (strEQ(d,"utime"))
X *d = toupper(*d);
X ID(d);
X case 'v': case 'V':
X SNARFWORD;
X if (strEQ(d,"values"))
X *d = toupper(*d);
X ID(d);
X case 'w': case 'W':
X SNARFWORD;
X if (strEQ(d,"while"))
X XTERM(WHILE);
X if (strEQ(d,"write"))
X *d = toupper(*d);
X else if (strEQ(d,"wait"))
X *d = toupper(*d);
X ID(d);
X case 'x': case 'X':
X SNARFWORD;
X if (strEQ(d,"x"))
X *d = toupper(*d);
X ID(d);
X case 'y': case 'Y':
X SNARFWORD;
X if (strEQ(d,"y"))
X *d = toupper(*d);
X ID(d);
X case 'z': case 'Z':
X SNARFWORD;
X ID(d);
X }
X}
X
Xchar *
Xscanpat(s)
Xregister char *s;
X{
X register char *d;
X
X switch (*s++) {
X case '/':
X break;
X default:
X fatal("Search pattern not found:\n%s",str_get(linestr));
X }
X
X d = tokenbuf;
X for (; *s; s++,d++) {
X if (*s == '\\') {
X if (s[1] == '/')
X *d++ = *s++;
X else if (s[1] == '\\')
X *d++ = *s++;
X }
X else if (*s == '[') {
X *d++ = *s++;
X do {
X if (*s == '\\' && s[1])
X *d++ = *s++;
X if (*s == '/' || (*s == '-' && s[1] == ']'))
X *d++ = '\\';
X *d++ = *s++;
X } while (*s && *s != ']');
X }
X else if (*s == '/')
X break;
X *d = *s;
X }
X *d = '\0';
X
X if (!*s)
X fatal("Search pattern not terminated:\n%s",str_get(linestr));
X s++;
X yylval = string(tokenbuf,0);
X return s;
X}
X
Xyyerror(s)
Xchar *s;
X{
X fprintf(stderr,"%s in file %s at line %d\n",
X s,filename,line);
X}
X
Xchar *
Xscannum(s)
Xregister char *s;
X{
X register char *d;
X
X switch (*s) {
X case '1': case '2': case '3': case '4': case '5':
X case '6': case '7': case '8': case '9': case '0' : case '.':
X d = tokenbuf;
X while (isdigit(*s)) {
X *d++ = *s++;
X }
X if (*s == '.' && index("0123456789eE",s[1])) {
X *d++ = *s++;
X while (isdigit(*s)) {
X *d++ = *s++;
X }
X }
X if (index("eE",*s) && index("+-0123456789",s[1])) {
X *d++ = *s++;
X if (*s == '+' || *s == '-')
X *d++ = *s++;
X while (isdigit(*s))
X *d++ = *s++;
X }
X *d = '\0';
X yylval = string(tokenbuf,0);
X break;
X }
X return s;
X}
X
Xstring(ptr,len)
Xchar *ptr;
X{
X int retval = mop;
X
X ops[mop++].ival = OSTRING + (1<<8);
X if (!len)
X len = strlen(ptr);
X ops[mop].cval = safemalloc(len+1);
X strncpy(ops[mop].cval,ptr,len);
X ops[mop++].cval[len] = '\0';
X if (mop >= OPSMAX)
X fatal("Recompile a2p with larger OPSMAX\n");
X return retval;
X}
X
Xoper0(type)
Xint type;
X{
X int retval = mop;
X
X if (type > 255)
X fatal("type > 255 (%d)\n",type);
X ops[mop++].ival = type;
X if (mop >= OPSMAX)
X fatal("Recompile a2p with larger OPSMAX\n");
X return retval;
X}
X
Xoper1(type,arg1)
Xint type;
Xint arg1;
X{
X int retval = mop;
X
X if (type > 255)
X fatal("type > 255 (%d)\n",type);
X ops[mop++].ival = type + (1<<8);
X ops[mop++].ival = arg1;
X if (mop >= OPSMAX)
X fatal("Recompile a2p with larger OPSMAX\n");
X return retval;
X}
X
Xoper2(type,arg1,arg2)
Xint type;
Xint arg1;
Xint arg2;
X{
X int retval = mop;
X
X if (type > 255)
X fatal("type > 255 (%d)\n",type);
X ops[mop++].ival = type + (2<<8);
X ops[mop++].ival = arg1;
X ops[mop++].ival = arg2;
X if (mop >= OPSMAX)
X fatal("Recompile a2p with larger OPSMAX\n");
X return retval;
X}
X
Xoper3(type,arg1,arg2,arg3)
Xint type;
Xint arg1;
Xint arg2;
Xint arg3;
X{
X int retval = mop;
X
X if (type > 255)
X fatal("type > 255 (%d)\n",type);
X ops[mop++].ival = type + (3<<8);
X ops[mop++].ival = arg1;
X ops[mop++].ival = arg2;
X ops[mop++].ival = arg3;
X if (mop >= OPSMAX)
X fatal("Recompile a2p with larger OPSMAX\n");
X return retval;
X}
X
Xoper4(type,arg1,arg2,arg3,arg4)
Xint type;
Xint arg1;
Xint arg2;
Xint arg3;
Xint arg4;
X{
X int retval = mop;
X
X if (type > 255)
X fatal("type > 255 (%d)\n",type);
X ops[mop++].ival = type + (4<<8);
X ops[mop++].ival = arg1;
X ops[mop++].ival = arg2;
X ops[mop++].ival = arg3;
X ops[mop++].ival = arg4;
X if (mop >= OPSMAX)
X fatal("Recompile a2p with larger OPSMAX\n");
X return retval;
X}
X
Xoper5(type,arg1,arg2,arg3,arg4,arg5)
Xint type;
Xint arg1;
Xint arg2;
Xint arg3;
Xint arg4;
Xint arg5;
X{
X int retval = mop;
X
X if (type > 255)
X fatal("type > 255 (%d)\n",type);
X ops[mop++].ival = type + (5<<8);
X ops[mop++].ival = arg1;
X ops[mop++].ival = arg2;
X ops[mop++].ival = arg3;
X ops[mop++].ival = arg4;
X ops[mop++].ival = arg5;
X if (mop >= OPSMAX)
X fatal("Recompile a2p with larger OPSMAX\n");
X return retval;
X}
X
Xint depth = 0;
X
Xdump(branch)
Xint branch;
X{
X register int type;
X register int len;
X register int i;
X
X type = ops[branch].ival;
X len = type >> 8;
X type &= 255;
X for (i=depth; i; i--)
X printf(" ");
X if (type == OSTRING) {
X printf("%-5d\"%s\"\n",branch,ops[branch+1].cval);
X }
X else {
X printf("(%-5d%s %d\n",branch,opname[type],len);
X depth++;
X for (i=1; i<=len; i++)
X dump(ops[branch+i].ival);
X depth--;
X for (i=depth; i; i--)
X printf(" ");
X printf(")\n");
X }
X}
X
Xbl(arg,maybe)
Xint arg;
Xint maybe;
X{
X if (!arg)
X return 0;
X else if ((ops[arg].ival & 255) != OBLOCK)
X return oper2(OBLOCK,arg,maybe);
X else if ((ops[arg].ival >> 8) < 2)
X return oper2(OBLOCK,ops[arg+1].ival,maybe);
X else
X return arg;
X}
X
Xfixup(str)
XSTR *str;
X{
X register char *s;
X register char *t;
X
X for (s = str->str_ptr; *s; s++) {
X if (*s == ';' && s[1] == ' ' && s[2] == '\n') {
X strcpy(s+1,s+2);
X s++;
X }
X else if (*s == '\n') {
X for (t = s+1; isspace(*t & 127); t++) ;
X t--;
X while (isspace(*t & 127) && *t != '\n') t--;
X if (*t == '\n' && t-s > 1) {
X if (s[-1] == '{')
X s--;
X strcpy(s+1,t);
X }
X s++;
X }
X }
X}
X
Xputlines(str)
XSTR *str;
X{
X register char *d, *s, *t, *e;
X register int pos, newpos;
X
X d = tokenbuf;
X pos = 0;
X for (s = str->str_ptr; *s; s++) {
X *d++ = *s;
X pos++;
X if (*s == '\n') {
X *d = '\0';
X d = tokenbuf;
X pos = 0;
X putone();
X }
X else if (*s == '\t')
X pos += 7;
X if (pos > 78) { /* split a long line? */
X *d-- = '\0';
X newpos = 0;
X for (t = tokenbuf; isspace(*t & 127); t++) {
X if (*t == '\t')
X newpos += 8;
X else
X newpos += 1;
X }
X e = d;
X while (d > tokenbuf && (*d != ' ' || d[-1] != ';'))
X d--;
X if (d < t+10) {
X d = e;
X while (d > tokenbuf &&
X (*d != ' ' || d[-1] != '|' || d[-2] != '|') )
X d--;
X }
X if (d < t+10) {
X d = e;
X while (d > tokenbuf &&
X (*d != ' ' || d[-1] != '&' || d[-2] != '&') )
X d--;
X }
X if (d < t+10) {
X d = e;
X while (d > tokenbuf && (*d != ' ' || d[-1] != ','))
X d--;
X }
X if (d < t+10) {
X d = e;
X while (d > tokenbuf && *d != ' ')
X d--;
X }
X if (d > t+3) {
X char save[2048];
X strcpy(save, d);
X *d = '\n';
X d[1] = '\0';
X putone();
X putchar('\n');
X if (d[-1] != ';' && !(newpos % 4)) {
X *t++ = ' ';
X *t++ = ' ';
X newpos += 2;
X }
X strcpy(t,save+1);
X newpos += strlen(t);
X d = t + strlen(t);
X pos = newpos;
X }
X else
X d = e + 1;
X }
X }
X}
X
Xputone()
X{
X register char *t;
X
X for (t = tokenbuf; *t; t++) {
X *t &= 127;
X if (*t == 127) {
X *t = ' ';
X strcpy(t+strlen(t)-1, "\t#???\n");
X checkers++;
X }
X }
X t = tokenbuf;
X if (*t == '#') {
X if (strnEQ(t,"#!/bin/awk",10) || strnEQ(t,"#! /bin/awk",11))
X return;
X if (strnEQ(t,"#!/usr/bin/awk",14) || strnEQ(t,"#! /usr/bin/awk",15))
X return;
X }
X fputs(tokenbuf,stdout);
X}
X
Xnumary(arg)
Xint arg;
X{
X STR *key;
X int dummy;
X
X key = walk(0,0,arg,&dummy,P_MIN);
X str_cat(key,"[]");
X hstore(symtab,key->str_ptr,str_make("1"));
X str_free(key);
X set_array_base = TRUE;
X return arg;
X}
X
Xrememberargs(arg)
Xint arg;
X{
X int type;
X STR *str;
X
X if (!arg)
X return arg;
X type = ops[arg].ival & 255;
X if (type == OCOMMA) {
X rememberargs(ops[arg+1].ival);
X rememberargs(ops[arg+3].ival);
X }
X else if (type == OVAR) {
X str = str_new(0);
X hstore(curarghash,ops[ops[arg+1].ival+1].cval,str);
X }
X else
X fatal("panic: unknown argument type %d, line %d\n",type,line);
X return arg;
X}
X
Xaryrefarg(arg)
Xint arg;
X{
X int type = ops[arg].ival & 255;
X STR *str;
X
X if (type != OSTRING)
X fatal("panic: aryrefarg %d, line %d\n",type,line);
X str = hfetch(curarghash,ops[arg+1].cval);
X if (str)
X str_set(str,"*");
X return arg;
X}
X
Xfixfargs(name,arg,prevargs)
Xint name;
Xint arg;
Xint prevargs;
X{
X int type;
X STR *str;
X int numargs;
X
X if (!arg)
X return prevargs;
X type = ops[arg].ival & 255;
X if (type == OCOMMA) {
X numargs = fixfargs(name,ops[arg+1].ival,prevargs);
X numargs = fixfargs(name,ops[arg+3].ival,numargs);
X }
X else if (type == OVAR) {
X str = hfetch(curarghash,ops[ops[arg+1].ival+1].cval);
X if (strEQ(str_get(str),"*")) {
X char tmpbuf[128];
X
X str_set(str,""); /* in case another routine has this */
X ops[arg].ival &= ~255;
X ops[arg].ival |= OSTAR;
X sprintf(tmpbuf,"%s:%d",ops[name+1].cval,prevargs);
X fprintf(stderr,"Adding %s\n",tmpbuf);
X str = str_new(0);
X str_set(str,"*");
X hstore(curarghash,tmpbuf,str);
X }
X numargs = prevargs + 1;
X }
X else
X fatal("panic: unknown argument type %d, arg %d, line %d\n",
X type,prevargs+1,line);
X return numargs;
X}
X
Xfixrargs(name,arg,prevargs)
Xchar *name;
Xint arg;
Xint prevargs;
X{
X int type;
X STR *str;
X int numargs;
X
X if (!arg)
X return prevargs;
X type = ops[arg].ival & 255;
X if (type == OCOMMA) {
X numargs = fixrargs(name,ops[arg+1].ival,prevargs);
X numargs = fixrargs(name,ops[arg+3].ival,numargs);
X }
X else {
X char tmpbuf[128];
X
X sprintf(tmpbuf,"%s:%d",name,prevargs);
X str = hfetch(curarghash,tmpbuf);
X fprintf(stderr,"Looking for %s\n",tmpbuf);
X if (str && strEQ(str->str_ptr,"*")) {
X if (type == OVAR || type == OSTAR) {
X ops[arg].ival &= ~255;
X ops[arg].ival |= OSTAR;
X }
X else
X fatal("Can't pass expression by reference as arg %d of %s\n",
X prevargs+1, name);
X }
X numargs = prevargs + 1;
X }
X return numargs;
X}
X
!STUFFY!FUNK!
echo Extracting stab.c
sed >stab.c <<'!STUFFY!FUNK!' -e 's/X//'
X/* $RCSfile: stab.c,v $$Revision: 4.0.1.1 $$Date: 91/04/12 09:10:24 $
X *
X * Copyright (c) 1989, Larry Wall
X *
X * You may distribute under the terms of the GNU General Public License
X * as specified in the README file that comes with the perl 3.0 kit.
X *
X * $Log: stab.c,v $
X * Revision 4.0.1.1 91/04/12 09:10:24 lwall
X * patch1: Configure now differentiates getgroups() type from getgid() type
X * patch1: you may now use "die" and "caller" in a signal handler
X *
X * Revision 4.0 91/03/20 01:39:41 lwall
X * 4.0 baseline.
X *
X */
X
X#include "EXTERN.h"
X#include "perl.h"
X
X#if !defined(NSIG) || defined(M_UNIX) || defined(M_XENIX)
X#include <signal.h>
X#endif
X
Xstatic char *sig_name[] = {
X SIG_NAME,0
X};
X
X#ifdef VOIDSIG
X#define handlertype void
X#else
X#define handlertype int
X#endif
X
Xstatic handlertype sighandler();
X
Xstatic int origalen = 0;
X
XSTR *
Xstab_str(str)
XSTR *str;
X{
X STAB *stab = str->str_u.str_stab;
X register int paren;
X register char *s;
X register int i;
X
X if (str->str_rare)
X return stab_val(stab);
X
X switch (*stab->str_magic->str_ptr) {
X case '\004': /* ^D */
X#ifdef DEBUGGING
X str_numset(stab_val(stab),(double)(debug & 32767));
X#endif
X break;
X case '\t': /* ^I */
X if (inplace)
X str_set(stab_val(stab), inplace);
X else
X str_sset(stab_val(stab),&str_undef);
X break;
X case '\024': /* ^T */
X str_numset(stab_val(stab),(double)basetime);
X break;
X case '\027': /* ^W */
X str_numset(stab_val(stab),(double)dowarn);
X break;
X case '1': case '2': case '3': case '4':
X case '5': case '6': case '7': case '8': case '9': case '&':
X if (curspat) {
X paren = atoi(stab_name(stab));
X getparen:
X if (curspat->spat_regexp &&
X paren <= curspat->spat_regexp->nparens &&
X (s = curspat->spat_regexp->startp[paren]) ) {
X i = curspat->spat_regexp->endp[paren] - s;
X if (i >= 0)
X str_nset(stab_val(stab),s,i);
X else
X str_sset(stab_val(stab),&str_undef);
X }
X else
X str_sset(stab_val(stab),&str_undef);
X }
X break;
X case '+':
X if (curspat) {
X paren = curspat->spat_regexp->lastparen;
X goto getparen;
X }
X break;
X case '`':
X if (curspat) {
X if (curspat->spat_regexp &&
X (s = curspat->spat_regexp->subbase) ) {
X i = curspat->spat_regexp->startp[0] - s;
X if (i >= 0)
X str_nset(stab_val(stab),s,i);
X else
X str_nset(stab_val(stab),"",0);
X }
X else
X str_nset(stab_val(stab),"",0);
X }
X break;
X case '\'':
X if (curspat) {
X if (curspat->spat_regexp &&
X (s = curspat->spat_regexp->endp[0]) ) {
X str_nset(stab_val(stab),s, curspat->spat_regexp->subend - s);
X }
X else
X str_nset(stab_val(stab),"",0);
X }
X break;
X case '.':
X#ifndef lint
X if (last_in_stab) {
X str_numset(stab_val(stab),(double)stab_io(last_in_stab)->lines);
X }
X#endif
X break;
X case '?':
X str_numset(stab_val(stab),(double)statusvalue);
X break;
X case '^':
X s = stab_io(curoutstab)->top_name;
X str_set(stab_val(stab),s);
X break;
X case '~':
X s = stab_io(curoutstab)->fmt_name;
X str_set(stab_val(stab),s);
X break;
X#ifndef lint
X case '=':
X str_numset(stab_val(stab),(double)stab_io(curoutstab)->page_len);
X break;
X case '-':
X str_numset(stab_val(stab),(double)stab_io(curoutstab)->lines_left);
X break;
X case '%':
X str_numset(stab_val(stab),(double)stab_io(curoutstab)->page);
X break;
X#endif
X case '/':
X break;
X case '[':
X str_numset(stab_val(stab),(double)arybase);
X break;
X case '|':
X if (!stab_io(curoutstab))
X stab_io(curoutstab) = stio_new();
X str_numset(stab_val(stab),
X (double)((stab_io(curoutstab)->flags & IOF_FLUSH) != 0) );
X break;
X case ',':
X str_nset(stab_val(stab),ofs,ofslen);
X break;
X case '\\':
X str_nset(stab_val(stab),ors,orslen);
X break;
X case '#':
X str_set(stab_val(stab),ofmt);
X break;
X case '!':
X str_numset(stab_val(stab), (double)errno);
X str_set(stab_val(stab), errno ? strerror(errno) : "");
X stab_val(stab)->str_nok = 1; /* what a wonderful hack! */
X break;
X case '<':
X str_numset(stab_val(stab),(double)uid);
X break;
X case '>':
X str_numset(stab_val(stab),(double)euid);
X break;
X case '(':
X s = buf;
X (void)sprintf(s,"%d",(int)gid);
X goto add_groups;
X case ')':
X s = buf;
X (void)sprintf(s,"%d",(int)egid);
X add_groups:
X while (*s) s++;
X#ifdef HAS_GETGROUPS
X#ifndef NGROUPS
X#define NGROUPS 32
X#endif
X {
X GROUPSTYPE gary[NGROUPS];
X
X i = getgroups(NGROUPS,gary);
X while (--i >= 0) {
X (void)sprintf(s," %ld", (long)gary[i]);
X while (*s) s++;
X }
X }
X#endif
X str_set(stab_val(stab),buf);
X break;
X case '*':
X break;
X case '0':
X break;
X default:
X {
X struct ufuncs *uf = (struct ufuncs *)str->str_ptr;
X
X if (uf && uf->uf_val)
X (*uf->uf_val)(uf->uf_index, stab_val(stab));
X }
X break;
X }
X return stab_val(stab);
X}
X
Xstabset(mstr,str)
Xregister STR *mstr;
XSTR *str;
X{
X STAB *stab = mstr->str_u.str_stab;
X register char *s;
X int i;
X
X switch (mstr->str_rare) {
X case 'E':
X setenv(mstr->str_ptr,str_get(str));
X /* And you'll never guess what the dog had */
X /* in its mouth... */
X#ifdef TAINT
X if (strEQ(mstr->str_ptr,"PATH")) {
X char *strend = str->str_ptr + str->str_cur;
X
X s = str->str_ptr;
X while (s < strend) {
X s = cpytill(tokenbuf,s,strend,':',&i);
X s++;
X if (*tokenbuf != '/'
X || (stat(tokenbuf,&statbuf) && (statbuf.st_mode & 2)) )
X str->str_tainted = 2;
X }
X }
X#endif
X break;
X case 'S':
X s = str_get(str);
X i = whichsig(mstr->str_ptr); /* ...no, a brick */
X if (strEQ(s,"IGNORE"))
X#ifndef lint
X (void)signal(i,SIG_IGN);
X#else
X ;
X#endif
X else if (strEQ(s,"DEFAULT") || !*s)
X (void)signal(i,SIG_DFL);
X else {
X (void)signal(i,sighandler);
X if (!index(s,'\'')) {
X sprintf(tokenbuf, "main'%s",s);
X str_set(str,tokenbuf);
X }
X }
X break;
X#ifdef SOME_DBM
X case 'D':
X hdbmstore(stab_hash(stab),mstr->str_ptr,mstr->str_cur,str);
X break;
X#endif
X case 'L':
X {
X CMD *cmd;
X
X i = str_true(str);
X str = afetch(stab_xarray(stab),atoi(mstr->str_ptr), FALSE);
X cmd = str->str_magic->str_u.str_cmd;
X cmd->c_flags &= ~CF_OPTIMIZE;
X cmd->c_flags |= i? CFT_D1 : CFT_D0;
X }
X break;
X case '#':
X afill(stab_array(stab), (int)str_gnum(str) - arybase);
X break;
X case 'X': /* merely a copy of a * string */
X break;
X case '*':
X s = str_get(str);
X if (strNE(s,"StB") || str->str_cur != sizeof(STBP)) {
X if (!*s) {
X STBP *stbp;
X
X (void)savenostab(stab); /* schedule a free of this stab */
X if (stab->str_len)
X Safefree(stab->str_ptr);
X Newz(601,stbp, 1, STBP);
X stab->str_ptr = stbp;
X stab->str_len = stab->str_cur = sizeof(STBP);
X stab->str_pok = 1;
X strcpy(stab_magic(stab),"StB");
X stab_val(stab) = Str_new(70,0);
X stab_line(stab) = curcmd->c_line;
X stab_stash(stab) = curcmd->c_stash;
X }
X else {
X stab = stabent(s,TRUE);
X if (!stab_xarray(stab))
X aadd(stab);
X if (!stab_xhash(stab))
X hadd(stab);
X if (!stab_io(stab))
X stab_io(stab) = stio_new();
X }
X str_sset(str,stab);
X }
X break;
X case 's': {
X struct lstring *lstr = (struct lstring*)str;
X char *tmps;
X
X mstr->str_rare = 0;
X str->str_magic = Nullstr;
X tmps = str_get(str);
X str_insert(mstr,lstr->lstr_offset,lstr->lstr_len,
X tmps,str->str_cur);
X }
X break;
X
X case 'v':
X do_vecset(mstr,str);
X break;
X
X case 0:
X switch (*stab->str_magic->str_ptr) {
X case '\004': /* ^D */
X#ifdef DEBUGGING
X debug = (int)(str_gnum(str)) | 32768;
X#endif
X break;
X case '\t': /* ^I */
X if (inplace)
X Safefree(inplace);
X if (str->str_pok || str->str_nok)
X inplace = savestr(str_get(str));
X else
X inplace = Nullch;
X break;
X case '\024': /* ^T */
X basetime = (long)str_gnum(str);
X break;
X case '\027': /* ^W */
X dowarn = (bool)str_gnum(str);
X break;
X case '.':
X if (localizing)
X savesptr((STR**)&last_in_stab);
X break;
X case '^':
X Safefree(stab_io(curoutstab)->top_name);
X stab_io(curoutstab)->top_name = s = savestr(str_get(str));
X stab_io(curoutstab)->top_stab = stabent(s,TRUE);
X break;
X case '~':
X Safefree(stab_io(curoutstab)->fmt_name);
X stab_io(curoutstab)->fmt_name = s = savestr(str_get(str));
X stab_io(curoutstab)->fmt_stab = stabent(s,TRUE);
X break;
X case '=':
X stab_io(curoutstab)->page_len = (long)str_gnum(str);
X break;
X case '-':
X stab_io(curoutstab)->lines_left = (long)str_gnum(str);
X if (stab_io(curoutstab)->lines_left < 0L)
X stab_io(curoutstab)->lines_left = 0L;
X break;
X case '%':
X stab_io(curoutstab)->page = (long)str_gnum(str);
X break;
X case '|':
X if (!stab_io(curoutstab))
X stab_io(curoutstab) = stio_new();
X stab_io(curoutstab)->flags &= ~IOF_FLUSH;
X if (str_gnum(str) != 0.0) {
X stab_io(curoutstab)->flags |= IOF_FLUSH;
X }
X break;
X case '*':
X i = (int)str_gnum(str);
X multiline = (i != 0);
X break;
X case '/':
X if (str->str_pok) {
X rs = str_get(str);
X rslen = str->str_cur;
X if (!rslen) {
X rs = "\n\n";
X rslen = 2;
X }
X rschar = rs[rslen - 1];
X }
X else {
X rschar = 0777; /* fake a non-existent char */
X rslen = 1;
X }
X break;
X case '\\':
X if (ors)
X Safefree(ors);
X ors = savestr(str_get(str));
X orslen = str->str_cur;
X break;
X case ',':
X if (ofs)
X Safefree(ofs);
X ofs = savestr(str_get(str));
X ofslen = str->str_cur;
X break;
X case '#':
X if (ofmt)
X Safefree(ofmt);
X ofmt = savestr(str_get(str));
X break;
X case '[':
X arybase = (int)str_gnum(str);
X break;
X case '?':
X statusvalue = U_S(str_gnum(str));
X break;
X case '!':
X errno = (int)str_gnum(str); /* will anyone ever use this? */
X break;
X case '<':
X uid = (int)str_gnum(str);
X#ifdef HAS_SETREUID
X if (delaymagic) {
X delaymagic |= DM_REUID;
X break; /* don't do magic till later */
X }
X#endif /* HAS_SETREUID */
X#ifdef HAS_SETRUID
X if (setruid((UIDTYPE)uid) < 0)
X uid = (int)getuid();
X#else
X#ifdef HAS_SETREUID
X if (setreuid((UIDTYPE)uid, (UIDTYPE)-1) < 0)
X uid = (int)getuid();
X#else
X if (uid == euid) /* special case $< = $> */
X setuid(uid);
X else
X fatal("setruid() not implemented");
X#endif
X#endif
X break;
X case '>':
X euid = (int)str_gnum(str);
X#ifdef HAS_SETREUID
X if (delaymagic) {
X delaymagic |= DM_REUID;
X break; /* don't do magic till later */
X }
X#endif /* HAS_SETREUID */
X#ifdef HAS_SETEUID
X if (seteuid((UIDTYPE)euid) < 0)
X euid = (int)geteuid();
X#else
X#ifdef HAS_SETREUID
X if (setreuid((UIDTYPE)-1, (UIDTYPE)euid) < 0)
X euid = (int)geteuid();
X#else
X if (euid == uid) /* special case $> = $< */
X setuid(euid);
X else
X fatal("seteuid() not implemented");
X#endif
X#endif
X break;
X case '(':
X gid = (int)str_gnum(str);
X#ifdef HAS_SETREGID
X if (delaymagic) {
X delaymagic |= DM_REGID;
X break; /* don't do magic till later */
X }
X#endif /* HAS_SETREGID */
X#ifdef HAS_SETRGID
X (void)setrgid((GIDTYPE)gid);
X#else
X#ifdef HAS_SETREGID
X (void)setregid((GIDTYPE)gid, (GIDTYPE)-1);
X#else
X fatal("setrgid() not implemented");
X#endif
X#endif
X break;
X case ')':
X egid = (int)str_gnum(str);
X#ifdef HAS_SETREGID
X if (delaymagic) {
X delaymagic |= DM_REGID;
X break; /* don't do magic till later */
X }
X#endif /* HAS_SETREGID */
X#ifdef HAS_SETEGID
X (void)setegid((GIDTYPE)egid);
X#else
X#ifdef HAS_SETREGID
X (void)setregid((GIDTYPE)-1, (GIDTYPE)egid);
X#else
X fatal("setegid() not implemented");
X#endif
X#endif
X break;
X case ':':
X chopset = str_get(str);
X break;
X case '0':
X if (!origalen) {
X s = origargv[0];
X s += strlen(s);
X /* See if all the arguments are contiguous in memory */
X for (i = 1; i < origargc; i++) {
X if (origargv[i] == s + 1)
X s += strlen(++s); /* this one is ok too */
X }
X if (origenviron[0] == s + 1) { /* can grab env area too? */
X setenv("NoNeSuCh", Nullch); /* force copy of environment */
X for (i = 0; origenviron[i]; i++)
X if (origenviron[i] == s + 1)
X s += strlen(++s);
X }
X origalen = s - origargv[0];
X }
X s = str_get(str);
X i = str->str_cur;
X if (i >= origalen) {
X i = origalen;
X str->str_cur = i;
X str->str_ptr[i] = '\0';
X bcopy(s, origargv[0], i);
X }
X else {
X bcopy(s, origargv[0], i);
X s = origargv[0]+i;
X *s++ = '\0';
X while (++i < origalen)
X *s++ = ' ';
X }
X break;
X default:
X {
X struct ufuncs *uf = (struct ufuncs *)str->str_magic->str_ptr;
X
X if (uf && uf->uf_set)
X (*uf->uf_set)(uf->uf_index, str);
X }
X break;
X }
X break;
X }
X}
X
Xwhichsig(sig)
Xchar *sig;
X{
X register char **sigv;
X
X for (sigv = sig_name+1; *sigv; sigv++)
X if (strEQ(sig,*sigv))
X return sigv - sig_name;
X#ifdef SIGCLD
X if (strEQ(sig,"CHLD"))
X return SIGCLD;
X#endif
X#ifdef SIGCHLD
X if (strEQ(sig,"CLD"))
X return SIGCHLD;
X#endif
X return 0;
X}
X
Xstatic handlertype
Xsighandler(sig)
Xint sig;
X{
X STAB *stab;
X STR *str;
X int oldsave = savestack->ary_fill;
X int oldtmps_base = tmps_base;
X register CSV *csv;
X SUBR *sub;
X
X#ifdef OS2 /* or anybody else who requires SIG_ACK */
X signal(sig, SIG_ACK);
X#endif
X stab = stabent(
X str_get(hfetch(stab_hash(sigstab),sig_name[sig],strlen(sig_name[sig]),
X TRUE)), TRUE);
X sub = stab_sub(stab);
X if (!sub && *sig_name[sig] == 'C' && instr(sig_name[sig],"LD")) {
X if (sig_name[sig][1] == 'H')
X stab = stabent(str_get(hfetch(stab_hash(sigstab),"CLD",3,TRUE)),
X TRUE);
X else
X stab = stabent(str_get(hfetch(stab_hash(sigstab),"CHLD",4,TRUE)),
X TRUE);
X sub = stab_sub(stab); /* gag */
X }
X if (!sub) {
X if (dowarn)
X warn("SIG%s handler \"%s\" not defined.\n",
X sig_name[sig], stab_name(stab) );
X return;
X }
X saveaptr(&stack);
X str = Str_new(15, sizeof(CSV));
X str->str_state = SS_SCSV;
X (void)apush(savestack,str);
X csv = (CSV*)str->str_ptr;
X csv->sub = sub;
X csv->stab = stab;
X csv->curcsv = curcsv;
X csv->curcmd = curcmd;
X csv->depth = sub->depth;
X csv->wantarray = G_SCALAR;
X csv->hasargs = TRUE;
X csv->savearray = stab_xarray(defstab);
X csv->argarray = stab_xarray(defstab) = stack = anew(defstab);
X stack->ary_flags = 0;
X curcsv = csv;
X str = str_mortal(&str_undef);
X str_set(str,sig_name[sig]);
X (void)apush(stab_xarray(defstab),str);
X sub->depth++;
X if (sub->depth >= 2) { /* save temporaries on recursion? */
X if (sub->depth == 100 && dowarn)
X warn("Deep recursion on subroutine \"%s\"",stab_name(stab));
X savelist(sub->tosave->ary_array,sub->tosave->ary_fill);
X }
X
X tmps_base = tmps_max; /* protect our mortal string */
X (void)cmd_exec(sub->cmd,G_SCALAR,0); /* so do it already */
X tmps_base = oldtmps_base;
X
X restorelist(oldsave); /* put everything back */
X}
X
XSTAB *
Xaadd(stab)
Xregister STAB *stab;
X{
X if (!stab_xarray(stab))
X stab_xarray(stab) = anew(stab);
X return stab;
X}
X
XSTAB *
Xhadd(stab)
Xregister STAB *stab;
X{
X if (!stab_xhash(stab))
X stab_xhash(stab) = hnew(COEFFSIZE);
X return stab;
X}
X
XSTAB *
Xfstab(name)
Xchar *name;
X{
X char tmpbuf[1200];
X STAB *stab;
X
X sprintf(tmpbuf,"'_<%s", name);
X stab = stabent(tmpbuf, TRUE);
X str_set(stab_val(stab), name);
X if (perldb)
X (void)hadd(aadd(stab));
X return stab;
X}
X
XSTAB *
Xstabent(name,add)
Xregister char *name;
Xint add;
X{
X register STAB *stab;
X register STBP *stbp;
X int len;
X register char *namend;
X HASH *stash;
X char *sawquote = Nullch;
X char *prevquote = Nullch;
X bool global = FALSE;
X
X if (isascii(*name) && isupper(*name)) {
X if (*name > 'I') {
X if (*name == 'S' && (
X strEQ(name, "SIG") ||
X strEQ(name, "STDIN") ||
X strEQ(name, "STDOUT") ||
X strEQ(name, "STDERR") ))
X global = TRUE;
X }
X else if (*name > 'E') {
X if (*name == 'I' && strEQ(name, "INC"))
X global = TRUE;
X }
X else if (*name > 'A') {
X if (*name == 'E' && strEQ(name, "ENV"))
X global = TRUE;
X }
X else if (*name == 'A' && (
X strEQ(name, "ARGV") ||
X strEQ(name, "ARGVOUT") ))
X global = TRUE;
X }
X for (namend = name; *namend; namend++) {
X if (*namend == '\'' && namend[1])
X prevquote = sawquote, sawquote = namend;
X }
X if (sawquote == name && name[1]) {
X stash = defstash;
X sawquote = Nullch;
X name++;
X }
X else if (!isalpha(*name) || global)
X stash = defstash;
X else if (curcmd == &compiling)
X stash = curstash;
X else
X stash = curcmd->c_stash;
X if (sawquote) {
X char tmpbuf[256];
X char *s, *d;
X
X *sawquote = '\0';
X if (s = prevquote) {
X strncpy(tmpbuf,name,s-name+1);
X d = tmpbuf+(s-name+1);
X *d++ = '_';
X strcpy(d,s+1);
X }
X else {
X *tmpbuf = '_';
X strcpy(tmpbuf+1,name);
X }
X stab = stabent(tmpbuf,TRUE);
X if (!(stash = stab_xhash(stab)))
X stash = stab_xhash(stab) = hnew(0);
X if (!stash->tbl_name)
X stash->tbl_name = savestr(name);
X name = sawquote+1;
X *sawquote = '\'';
X }
X len = namend - name;
X stab = (STAB*)hfetch(stash,name,len,add);
X if (stab == (STAB*)&str_undef)
X return Nullstab;
X if (stab->str_pok) {
X stab->str_pok |= SP_MULTI;
X return stab;
X }
X else {
X if (stab->str_len)
X Safefree(stab->str_ptr);
X Newz(602,stbp, 1, STBP);
X stab->str_ptr = stbp;
X stab->str_len = stab->str_cur = sizeof(STBP);
X stab->str_pok = 1;
X strcpy(stab_magic(stab),"StB");
X stab_val(stab) = Str_new(72,0);
X stab_line(stab) = curcmd->c_line;
X str_magic(stab,stab,'*',name,len);
X stab_stash(stab) = stash;
X if (isdigit(*name) && *name != '0') {
X stab_flags(stab) = SF_VMAGIC;
X str_magic(stab_val(stab), stab, 0, Nullch, 0);
X }
X return stab;
X }
X}
X
Xstab_fullname(str,stab)
XSTR *str;
XSTAB *stab;
X{
X HASH *tb = stab_stash(stab);
X
X if (!tb)
X return;
X str_set(str,tb->tbl_name);
X str_ncat(str,"'", 1);
X str_scat(str,stab->str_magic);
X}
X
XSTIO *
Xstio_new()
X{
X STIO *stio;
X
X Newz(603,stio,1,STIO);
X stio->page_len = 60;
X return stio;
X}
X
Xstab_check(min,max)
Xint min;
Xregister int max;
X{
X register HENT *entry;
X register int i;
X register STAB *stab;
X
X for (i = min; i <= max; i++) {
X for (entry = defstash->tbl_array[i]; entry; entry = entry->hent_next) {
X stab = (STAB*)entry->hent_val;
X if (stab->str_pok & SP_MULTI)
X continue;
X curcmd->c_line = stab_line(stab);
X warn("Possible typo: \"%s\"", stab_name(stab));
X }
X }
X}
X
Xstatic int gensym = 0;
X
XSTAB *
Xgenstab()
X{
X (void)sprintf(tokenbuf,"_GEN_%d",gensym++);
X return stabent(tokenbuf,TRUE);
X}
X
X/* hopefully this is only called on local symbol table entries */
X
Xvoid
Xstab_clear(stab)
Xregister STAB *stab;
X{
X STIO *stio;
X SUBR *sub;
X
X afree(stab_xarray(stab));
X stab_xarray(stab) = Null(ARRAY*);
X (void)hfree(stab_xhash(stab), FALSE);
X stab_xhash(stab) = Null(HASH*);
X str_free(stab_val(stab));
X stab_val(stab) = Nullstr;
X if (stio = stab_io(stab)) {
X do_close(stab,FALSE);
X Safefree(stio->top_name);
X Safefree(stio->fmt_name);
X }
X if (sub = stab_sub(stab)) {
X afree(sub->tosave);
X cmd_free(sub->cmd);
X }
X Safefree(stab->str_ptr);
X stab->str_ptr = Null(STBP*);
X stab->str_len = 0;
X stab->str_cur = 0;
X}
X
X#if defined(CRIPPLED_CC) && (defined(iAPX286) || defined(M_I286) || defined(I80286))
X#define MICROPORT
X#endif
X
X#ifdef MICROPORT /* Microport 2.4 hack */
XARRAY *stab_array(stab)
Xregister STAB *stab;
X{
X if (((STBP*)(stab->str_ptr))->stbp_array)
X return ((STBP*)(stab->str_ptr))->stbp_array;
X else
X return ((STBP*)(aadd(stab)->str_ptr))->stbp_array;
X}
X
XHASH *stab_hash(stab)
Xregister STAB *stab;
X{
X if (((STBP*)(stab->str_ptr))->stbp_hash)
X return ((STBP*)(stab->str_ptr))->stbp_hash;
X else
X return ((STBP*)(hadd(stab)->str_ptr))->stbp_hash;
X}
X#endif /* Microport 2.4 hack */
!STUFFY!FUNK!
echo Extracting msdos/Makefile
sed >msdos/Makefile <<'!STUFFY!FUNK!' -e 's/X//'
X#
X# Makefile for compiling Perl under MS-DOS
X#
X# Needs a Unix compatible make.
X# This makefile works for an initial compilation. It does not
X# include all dependencies and thus is unsuitable for serious
X# development work. But who would do serious development under
X# MS-DOS?
X#
X# By Diomidis Spinellis, March 1990
X#
X
X# Source files
XSRC = array.c cmd.c cons.c consarg.c doarg.c doio.c dolist.c dump.c \
Xeval.c form.c hash.c perl.y perly.c regcomp.c regexec.c \
Xstab.c str.c toke.c util.c msdos.c popen.c directory.c
X
X# Object files
XOBJ = perl.obj array.obj cmd.obj cons.obj consarg.obj doarg.obj doio.obj \
Xdolist.obj dump.obj eval.obj form.obj hash.obj perly.obj regcomp.obj \
Xregexec.obj stab.obj str.obj toke.obj util.obj msdos.obj popen.obj \
Xdirectory.obj
X
X# Files in the MS-DOS distribution
XDOSFILES=config.h dir.h director.c glob.c makefile msdos.c popen.c readme.msd \
Xchanges.dds wishlist.dds patches manifest
X
X# Yacc flags
XYFLAGS=-d
X
X# Manual pages
XMAN=perlman.1 perlman.2 perlman.3 perlman.4
X
XCC=cc
X# Cflags for the files that break under the optimiser
XCPLAIN=-AL -DCRIPPLED_CC
X# Cflags for all the rest
XCFLAGS=$(CPLAIN) -Ox
X# Destination directory for executables
XDESTDIR=\usr\bin
X
X# Deliverables
Xall: perl.exe perl.1 glob.exe
X
Xperl.exe: $(OBJ)
X echo array+cmd+cons+consarg+doarg+doio+dolist+dump+ >perl.arp
X echo eval+form+hash+perl+perly+regcomp+regexec+ >>perl.arp
X echo stab+str+toke+util+msdos+popen+directory+\lib\setargv >>perl.arp
X echo perl.exe >>perl.arp
X echo nul >>perl.arp
X echo /stack:32767 /NOE >>perl.arp
X link @perl.arp
X
Xglob.exe: glob.c
X $(CC) glob.c \lib\setargv.obj -link /NOE
X
Xarray.obj: array.c
Xcmd.obj: cmd.c
Xcons.obj: cons.c perly.h
Xconsarg.obj: consarg.c
X $(CC) $(CPLAIN) -c consarg.c
Xdoarg.obj: doarg.c
Xdoio.obj: doio.c
Xdolist.obj: dolist.c
Xdump.obj: dump.c
Xeval.obj: eval.c evalargs.xc
Xform.obj: form.c
Xhash.obj: hash.c
Xperl.obj: perl.y
Xperly.obj: perly.c
Xregcomp.obj: regcomp.c
Xregexec.obj: regexec.c
Xstab.obj: stab.c
Xstr.obj: str.c
Xtoke.obj: toke.c
Xutil.obj: util.c
X $(CC) $(CPLAIN) -c util.c
Xperly.h: perl.obj
X mv ytab.h perly.h
Xdirectory.obj: directory.c
Xpopen.obj: popen.c
Xmsdos.obj: msdos.c
X
Xperl.1: $(MAN)
X nroff -man $(MAN) >perl.1
X
Xinstall: all
X exepack perl.exe $(DESTDIR)\perl.exe
X exepack glob.exe $(DESTDIR)\glob.exe
X
Xclean:
X rm -f *.obj *.exe perl.1 perly.h perl.arp
X
Xtags:
X ctags *.c *.h *.xc
X
Xdosperl:
X mv $(DOSFILES) ../perl30.new
X
Xdoskit:
X mv $(DOSFILES) ../msdos
!STUFFY!FUNK!
echo " "
echo "End of kit 24 (of 36)"
cat /dev/null >kit24isdone
run=''
config=''
for iskit in 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36; do
if test -f kit${iskit}isdone; then
run="$run $iskit"
else
todo="$todo $iskit"
fi
done
case $todo in
'')
echo "You have run all your kits. Please read README and then type Configure."
for combo in *:AA; do
if test -f "$combo"; then
realfile=`basename $combo :AA`
cat $realfile:[A-Z][A-Z] >$realfile
rm -rf $realfile:[A-Z][A-Z]
fi
done
rm -rf kit*isdone
chmod 755 Configure
;;
*) echo "You have run$run."
echo "You still need to run$todo."
;;
esac
: Someone might mail this, so...
exit
exit 0 # Just in case...
--
Kent Landfield INTERNET: kent@sparky.IMD.Sterling.COM
Sterling Software, IMD UUCP: uunet!sparky!kent
Phone: (402) 291-8300 FAX: (402) 291-4362
Please send comp.sources.misc-related mail to kent@uunet.uu.net.