perly.c

   1 char rcsid[] = "$Header: perly.c,v 2.0.1.1 88/06/28 16:36:49 root Exp $";
   2 /*
   3  * $Log:        perly.c,v $
   4  * Revision 2.0.1.1  88/06/28  16:36:49  root
   5  * patch1: added DOSUID code
   6  *
   7  * Revision 2.0  88/06/05  00:09:56  root
   8  * Baseline version 2.0.
   9  *
  10  */
  11
  12 #include "EXTERN.h"
  13 #include "perl.h"
  14 #include "perly.h"
  15
  16 extern char *tokename[];
  17 extern int yychar;
  18
  19 static int cmd_tosave();
  20 static int arg_tosave();
  21 static int spat_tosave();
  22
  23 main(argc,argv,env)
  24 register int argc;
  25 register char **argv;
  26 register char **env;
  27 {
  28     register STR *str;
  29     register char *s;
  30     char *index(), *strcpy(), *getenv();
  31     bool dosearch = FALSE;
  32 #ifdef DOSUID
  33     char **origargv = argv;
  34     char *validarg = "";
  35 #endif
  36
  37     uid = (int)getuid();
  38     euid = (int)geteuid();
  39     linestr = str_new(80);
  40     str_nset(linestr,"",0);
  41     str = str_make("");         /* first used for -I flags */
  42     incstab = aadd(stabent("INC",TRUE));
  43     for (argc--,argv++; argc; argc--,argv++) {
  44         if (argv[0][0] != '-' || !argv[0][1])
  45             break;
  46 #ifdef DOSUID
  47     if (*validarg)
  48         validarg = " PHOOEY ";
  49     else
  50         validarg = argv[0];
  51 #endif
  52         s = argv[0]+1;
  53       reswitch:
  54         switch (*s) {
  55         case 'a':
  56             minus_a = TRUE;
  57             s++;
  58             goto reswitch;
  59 #ifdef DEBUGGING
  60         case 'D':
  61             debug = atoi(s+1);
  62 #ifdef YYDEBUG
  63             yydebug = (debug & 1);
  64 #endif
  65             break;
  66 #endif
  67         case 'e':
  68             if (!e_fp) {
  69                 e_tmpname = strcpy(safemalloc(sizeof(TMPPATH)),TMPPATH);
  70                 mktemp(e_tmpname);
  71                 e_fp = fopen(e_tmpname,"w");
  72             }
  73             if (argv[1])
  74                 fputs(argv[1],e_fp);
  75             putc('\n', e_fp);
  76             argc--,argv++;
  77             break;
  78         case 'i':
  79             inplace = savestr(s+1);
  80             argvoutstab = stabent("ARGVOUT",TRUE);
  81             break;
  82         case 'I':
  83             str_cat(str,"-");
  84             str_cat(str,s);
  85             str_cat(str," ");
  86             if (s[1]) {
  87                 apush(incstab->stab_array,str_make(s+1));
  88             }
  89             else {
  90                 apush(incstab->stab_array,str_make(argv[1]));
  91                 str_cat(str,argv[1]);
  92                 argc--,argv++;
  93                 str_cat(str," ");
  94             }
  95             break;
  96         case 'n':
  97             minus_n = TRUE;
  98             s++;
  99             goto reswitch;
 100         case 'p':
 101             minus_p = TRUE;
 102             s++;
 103             goto reswitch;
 104         case 'P':
 105             preprocess = TRUE;
 106             s++;
 107             goto reswitch;
 108         case 's':
 109             doswitches = TRUE;
 110             s++;
 111             goto reswitch;
 112         case 'S':
 113             dosearch = TRUE;
 114             s++;
 115             goto reswitch;
 116         case 'U':
 117             unsafe = TRUE;
 118             s++;
 119             goto reswitch;
 120         case 'v':
 121             version();
 122             exit(0);
 123         case 'w':
 124             dowarn = TRUE;
 125             s++;
 126             goto reswitch;
 127         case '-':
 128             argc--,argv++;
 129             goto switch_end;
 130         case 0:
 131             break;
 132         default:
 133             fatal("Unrecognized switch: -%s",s);
 134         }
 135     }
 136   switch_end:
 137     if (e_fp) {
 138         fclose(e_fp);
 139         argc++,argv--;
 140         argv[0] = e_tmpname;
 141     }
 142 #ifndef PRIVLIB
 143 #define PRIVLIB "/usr/local/lib/perl"
 144 #endif
 145     apush(incstab->stab_array,str_make(PRIVLIB));
 146
 147     str_set(&str_no,No);
 148     str_set(&str_yes,Yes);
 149     init_eval();
 150
 151     /* open script */
 152
 153     if (argv[0] == Nullch)
 154         argv[0] = "-";
 155     if (dosearch && argv[0][0] != '/' && (s = getenv("PATH"))) {
 156         char *xfound = Nullch, *xfailed = Nullch;
 157
 158         while (*s) {
 159             s = cpytill(tokenbuf,s,':');
 160             if (*s)
 161                 s++;
 162             if (tokenbuf[0])
 163                 strcat(tokenbuf,"/");
 164             strcat(tokenbuf,argv[0]);
 165 #ifdef DEBUGGING
 166             if (debug & 1)
 167                 fprintf(stderr,"Looking for %s\n",tokenbuf);
 168 #endif
 169             if (stat(tokenbuf,&statbuf) < 0)            /* not there? */
 170                 continue;
 171             if ((statbuf.st_mode & S_IFMT) == S_IFREG
 172              && cando(S_IREAD,TRUE) && cando(S_IEXEC,TRUE)) {
 173                 xfound = tokenbuf;              /* bingo! */
 174                 break;
 175             }
 176             if (!xfailed)
 177                 xfailed = savestr(tokenbuf);
 178         }
 179         if (!xfound)
 180             fatal("Can't execute %s", xfailed);
 181         if (xfailed)
 182             safefree(xfailed);
 183         argv[0] = savestr(xfound);
 184     }
 185     filename = savestr(argv[0]);
 186     origfilename = savestr(filename);
 187     if (strEQ(filename,"-"))
 188         argv[0] = "";
 189     if (preprocess) {
 190         str_cat(str,"-I");
 191         str_cat(str,PRIVLIB);
 192         sprintf(buf, "\
 193 /bin/sed -e '/^[^#]/b' \
 194  -e '/^#[       ]*include[      ]/b' \
 195  -e '/^#[       ]*define[       ]/b' \
 196  -e '/^#[       ]*if[   ]/b' \
 197  -e '/^#[       ]*ifdef[        ]/b' \
 198  -e '/^#[       ]*ifndef[       ]/b' \
 199  -e '/^#[       ]*else/b' \
 200  -e '/^#[       ]*endif/b' \
 201  -e 's/^#.*//' \
 202  %s | %s -C %s %s",
 203           argv[0], CPPSTDIN, str_get(str), CPPMINUS);
 204 #ifdef IAMSUID
 205         if (euid != uid && !euid)       /* if running suidperl */
 206             seteuid(uid);               /* musn't stay setuid root */
 207 #endif
 208         rsfp = popen(buf,"r");
 209     }
 210     else if (!*argv[0])
 211         rsfp = stdin;
 212     else
 213         rsfp = fopen(argv[0],"r");
 214     if (rsfp == Nullfp) {
 215 #ifdef DOSUID
 216 #ifndef IAMSUID
 217         if (euid && stat(filename,&statbuf) >= 0 &&
 218           statbuf.st_mode & (S_ISUID|S_ISGID)) {
 219             execvp("suidperl", origargv);       /* try again */
 220             fatal("Can't do setuid\n");
 221         }
 222 #endif
 223 #endif
 224         fatal("Perl script \"%s\" doesn't seem to exist",filename);
 225     }
 226     str_free(str);              /* free -I directories */
 227
 228     /* do we need to emulate setuid on scripts? */
 229
 230     /* This code is for those BSD systems that have setuid #! scripts disabled
 231      * in the kernel because of a security problem.  Merely defining DOSUID
 232      * in perl will not fix that problem, but if you have disabled setuid
 233      * scripts in the kernel, this will attempt to emulate setuid and setgid
 234      * on scripts that have those now-otherwise-useless bits set.  The setuid
 235      * root version must be called suidperl.  If regular perl discovers that
 236      * it has opened a setuid script, it calls suidperl with the same argv
 237      * that it had.  If suidperl finds that the script it has just opened
 238      * is NOT setuid root, it sets the effective uid back to the uid.  We
 239      * don't just make perl setuid root because that loses the effective
 240      * uid we had before invoking perl, if it was different from the uid.
 241      *
 242      * DOSUID must be defined in both perl and suidperl, and IAMSUID must
 243      * be defined in suidperl only.  suidperl must be setuid root.  The
 244      * Configure script will set this up for you if you want it.
 245      */
 246 #ifdef DOSUID
 247     if (fstat(fileno(rsfp),&statbuf) < 0)       /* normal stat is insecure */
 248         fatal("Can't stat script \"%s\"",filename);
 249     if (statbuf.st_mode & (S_ISUID|S_ISGID)) {
 250         int len;
 251
 252         if (access(filename,1))         /* as a double check */
 253             fatal("Permission denied");
 254         if ((statbuf.st_mode & S_IFMT) != S_IFREG)
 255             fatal("Permission denied");
 256         doswitches = FALSE;             /* -s is insecure in suid */
 257         line++;
 258         if (fgets(tokenbuf,sizeof tokenbuf, rsfp) == Nullch ||
 259           strnNE(tokenbuf,"#!",2) )     /* required even on Sys V */
 260             fatal("No #! line");
 261         for (s = tokenbuf+2; !isspace(*s); s++) ;
 262         if (strnNE(s-4,"perl",4))       /* sanity check */
 263             fatal("Not a perl script");
 264         while (*s && isspace(*s)) s++;
 265         /*
 266          * #! arg must be what we saw above.  They can invoke it by
 267          * mentioning suidperl explicitly, but they may not add any strange
 268          * arguments beyond what #! says if they do invoke suidperl that way.
 269          */
 270         len = strlen(validarg);
 271         if (strEQ(validarg," PHOOEY ") ||
 272             strnNE(s,validarg,len) || !isspace(s[len]))
 273             fatal("Arg must be \"%s\"\n",s);
 274
 275         if (euid) {     /* oops, we're not the setuid root perl */
 276             fclose(rsfp);
 277 #ifndef IAMSUID
 278             execvp("suidperl", origargv);       /* try again */
 279 #endif
 280             fatal("Can't do setuid\n");
 281         }
 282
 283         if (statbuf.st_mode & S_ISUID && statbuf.st_uid != euid)
 284             seteuid(statbuf.st_uid);    /* all that for this */
 285         else if (uid)                   /* oops, mustn't run as root */
 286             seteuid(uid);
 287         if (statbuf.st_mode & S_ISGID && statbuf.st_gid != getegid())
 288             setegid(statbuf.st_gid);
 289         euid = (int)geteuid();
 290         if (!cando(S_IEXEC,TRUE))
 291             fatal("Permission denied\n");       /* they can't do this */
 292     }
 293 #ifdef IAMSUID
 294     else if (preprocess)
 295         fatal("-P not allowed for setuid/setgid script\n");
 296     else
 297         fatal("Script is not setuid/setgid in suidperl\n");
 298 #endif /* IAMSUID */
 299 #endif /* DOSUID */
 300
 301     defstab = stabent("_",TRUE);
 302
 303     /* init tokener */
 304
 305     bufptr = str_get(linestr);
 306
 307     /* now parse the report spec */
 308
 309     if (yyparse())
 310         fatal("Execution aborted due to compilation errors.\n");
 311
 312     if (dowarn) {
 313         stab_check('A','Z');
 314         stab_check('a','z');
 315     }
 316
 317     preprocess = FALSE;
 318     if (e_fp) {
 319         e_fp = Nullfp;
 320         UNLINK(e_tmpname);
 321     }
 322     argc--,argv++;      /* skip name of script */
 323     if (doswitches) {
 324         for (; argc > 0 && **argv == '-'; argc--,argv++) {
 325             if (argv[0][1] == '-') {
 326                 argc--,argv++;
 327                 break;
 328             }
 329             str_numset(stabent(argv[0]+1,TRUE)->stab_val,(double)1.0);
 330         }
 331     }
 332     if (argvstab = stabent("ARGV",allstabs)) {
 333         aadd(argvstab);
 334         for (; argc > 0; argc--,argv++) {
 335             apush(argvstab->stab_array,str_make(argv[0]));
 336         }
 337     }
 338     if (envstab = stabent("ENV",allstabs)) {
 339         hadd(envstab);
 340         for (; *env; env++) {
 341             if (!(s = index(*env,'=')))
 342                 continue;
 343             *s++ = '\0';
 344             str = str_make(s);
 345             str->str_link.str_magic = envstab;
 346             hstore(envstab->stab_hash,*env,str);
 347             *--s = '=';
 348         }
 349     }
 350     if (sigstab = stabent("SIG",allstabs))
 351         hadd(sigstab);
 352
 353     magicalize("!#?^~=-%0123456789.+&*()<>,\\/[|");
 354
 355     sawampersand = (stabent("&",FALSE) != Nullstab);
 356     if (tmpstab = stabent("0",allstabs))
 357         str_set(STAB_STR(tmpstab),origfilename);
 358     if (tmpstab = stabent("$",allstabs))
 359         str_numset(STAB_STR(tmpstab),(double)getpid());
 360
 361     tmpstab = stabent("stdin",TRUE);
 362     tmpstab->stab_io = stio_new();
 363     tmpstab->stab_io->fp = stdin;
 364
 365     tmpstab = stabent("stdout",TRUE);
 366     tmpstab->stab_io = stio_new();
 367     tmpstab->stab_io->fp = stdout;
 368     defoutstab = tmpstab;
 369     curoutstab = tmpstab;
 370
 371     tmpstab = stabent("stderr",TRUE);
 372     tmpstab->stab_io = stio_new();
 373     tmpstab->stab_io->fp = stderr;
 374
 375     savestack = anew(Nullstab);         /* for saving non-local values */
 376
 377     setjmp(top_env);    /* sets goto_targ on longjump */
 378
 379 #ifdef DEBUGGING
 380     if (debug & 1024)
 381         dump_cmd(main_root,Nullcmd);
 382     if (debug)
 383         fprintf(stderr,"\nEXECUTING...\n\n");
 384 #endif
 385
 386     /* do it */
 387
 388     (void) cmd_exec(main_root);
 389
 390     if (goto_targ)
 391         fatal("Can't find label \"%s\"--aborting",goto_targ);
 392     exit(0);
 393     /* NOTREACHED */
 394 }
 395
 396 magicalize(list)
 397 register char *list;
 398 {
 399     register STAB *stab;
 400     char sym[2];
 401
 402     sym[1] = '\0';
 403     while (*sym = *list++) {
 404         if (stab = stabent(sym,allstabs)) {
 405             stab->stab_flags = SF_VMAGIC;
 406             stab->stab_val->str_link.str_magic = stab;
 407         }
 408     }
 409 }
 410
 411 ARG *
 412 make_split(stab,arg)
 413 register STAB *stab;
 414 register ARG *arg;
 415 {
 416     register SPAT *spat = (SPAT *) safemalloc(sizeof (SPAT));
 417
 418     if (arg->arg_type != O_MATCH) {
 419         spat = (SPAT *) safemalloc(sizeof (SPAT));
 420         bzero((char *)spat, sizeof(SPAT));
 421         spat->spat_next = spat_root;    /* link into spat list */
 422         spat_root = spat;
 423
 424         spat->spat_runtime = arg;
 425         arg = make_match(O_MATCH,stab2arg(A_STAB,defstab),spat);
 426     }
 427     arg->arg_type = O_SPLIT;
 428     spat = arg[2].arg_ptr.arg_spat;
 429     spat->spat_repl = stab2arg(A_STAB,aadd(stab));
 430     if (spat->spat_short) {     /* exact match can bypass regexec() */
 431         if (!((spat->spat_flags & SPAT_SCANFIRST) &&
 432             (spat->spat_flags & SPAT_ALL) )) {
 433             str_free(spat->spat_short);
 434             spat->spat_short = Nullstr;
 435         }
 436     }
 437     return arg;
 438 }
 439
 440 SUBR *
 441 make_sub(name,cmd)
 442 char *name;
 443 CMD *cmd;
 444 {
 445     register SUBR *sub = (SUBR *) safemalloc(sizeof (SUBR));
 446     STAB *stab = stabent(name,TRUE);
 447
 448     if (stab->stab_sub) {
 449         if (dowarn) {
 450             line_t oldline = line;
 451
 452             if (cmd)
 453                 line = cmd->c_line;
 454             warn("Subroutine %s redefined",name);
 455             line = oldline;
 456         }
 457         cmd_free(stab->stab_sub->cmd);
 458         afree(stab->stab_sub->tosave);
 459         safefree((char*)stab->stab_sub);
 460     }
 461     bzero((char *)sub, sizeof(SUBR));
 462     sub->cmd = cmd;
 463     sub->filename = filename;
 464     tosave = anew(Nullstab);
 465     tosave->ary_fill = 0;       /* make 1 based */
 466     cmd_tosave(cmd);            /* this builds the tosave array */
 467     sub->tosave = tosave;
 468     stab->stab_sub = sub;
 469 }
 470
 471 CMD *
 472 block_head(tail)
 473 register CMD *tail;
 474 {
 475     if (tail == Nullcmd) {
 476         return tail;
 477     }
 478     return tail->c_head;
 479 }
 480
 481 CMD *
 482 append_line(head,tail)
 483 register CMD *head;
 484 register CMD *tail;
 485 {
 486     if (tail == Nullcmd)
 487         return head;
 488     if (!tail->c_head)                  /* make sure tail is well formed */
 489         tail->c_head = tail;
 490     if (head != Nullcmd) {
 491         tail = tail->c_head;            /* get to start of tail list */
 492         if (!head->c_head)
 493             head->c_head = head;        /* start a new head list */
 494         while (head->c_next) {
 495             head->c_next->c_head = head->c_head;
 496             head = head->c_next;        /* get to end of head list */
 497         }
 498         head->c_next = tail;            /* link to end of old list */
 499         tail->c_head = head->c_head;    /* propagate head pointer */
 500     }
 501     while (tail->c_next) {
 502         tail->c_next->c_head = tail->c_head;
 503         tail = tail->c_next;
 504     }
 505     return tail;
 506 }
 507
 508 CMD *
 509 make_acmd(type,stab,cond,arg)
 510 int type;
 511 STAB *stab;
 512 ARG *cond;
 513 ARG *arg;
 514 {
 515     register CMD *cmd = (CMD *) safemalloc(sizeof (CMD));
 516
 517     bzero((char *)cmd, sizeof(CMD));
 518     cmd->c_type = type;
 519     cmd->ucmd.acmd.ac_stab = stab;
 520     cmd->ucmd.acmd.ac_expr = arg;
 521     cmd->c_expr = cond;
 522     if (cond) {
 523         opt_arg(cmd,1,1);
 524         cmd->c_flags |= CF_COND;
 525     }
 526     if (cmdline != NOLINE) {
 527         cmd->c_line = cmdline;
 528         cmdline = NOLINE;
 529     }
 530     cmd->c_file = filename;
 531     return cmd;
 532 }
 533
 534 CMD *
 535 make_ccmd(type,arg,cblock)
 536 int type;
 537 register ARG *arg;
 538 struct compcmd cblock;
 539 {
 540     register CMD *cmd = (CMD *) safemalloc(sizeof (CMD));
 541
 542     bzero((char *)cmd, sizeof(CMD));
 543     cmd->c_type = type;
 544     cmd->c_expr = arg;
 545     cmd->ucmd.ccmd.cc_true = cblock.comp_true;
 546     cmd->ucmd.ccmd.cc_alt = cblock.comp_alt;
 547     if (arg) {
 548         opt_arg(cmd,1,0);
 549         cmd->c_flags |= CF_COND;
 550     }
 551     if (cmdline != NOLINE) {
 552         cmd->c_line = cmdline;
 553         cmdline = NOLINE;
 554     }
 555     return cmd;
 556 }
 557
 558 void
 559 opt_arg(cmd,fliporflop,acmd)
 560 register CMD *cmd;
 561 int fliporflop;
 562 int acmd;
 563 {
 564     register ARG *arg;
 565     int opt = CFT_EVAL;
 566     int sure = 0;
 567     ARG *arg2;
 568     char *tmps; /* for True macro */
 569     int context = 0;    /* 0 = normal, 1 = before &&, 2 = before || */
 570     int flp = fliporflop;
 571
 572     if (!cmd)
 573         return;
 574     arg = cmd->c_expr;
 575
 576     /* Can we turn && and || into if and unless? */
 577
 578     if (acmd && !cmd->ucmd.acmd.ac_expr &&
 579       (arg->arg_type == O_AND || arg->arg_type == O_OR) ) {
 580         dehoist(arg,1);
 581         dehoist(arg,2);
 582         cmd->ucmd.acmd.ac_expr = arg[2].arg_ptr.arg_arg;
 583         cmd->c_expr = arg[1].arg_ptr.arg_arg;
 584         if (arg->arg_type == O_OR)
 585             cmd->c_flags ^= CF_INVERT;          /* || is like unless */
 586         arg->arg_len = 0;
 587         arg_free(arg);
 588         arg = cmd->c_expr;
 589     }
 590
 591     /* Turn "if (!expr)" into "unless (expr)" */
 592
 593     while (arg->arg_type == O_NOT) {
 594         dehoist(arg,1);
 595         cmd->c_flags ^= CF_INVERT;              /* flip sense of cmd */
 596         cmd->c_expr = arg[1].arg_ptr.arg_arg;   /* hoist the rest of expr */
 597         free_arg(arg);
 598         arg = cmd->c_expr;                      /* here we go again */
 599     }
 600
 601     if (!arg->arg_len) {                /* sanity check */
 602         cmd->c_flags |= opt;
 603         return;
 604     }
 605
 606     /* for "cond .. cond" we set up for the initial check */
 607
 608     if (arg->arg_type == O_FLIP)
 609         context |= 4;
 610
 611     /* for "cond && expr" and "cond || expr" we can ignore expr, sort of */
 612
 613     if (arg->arg_type == O_AND)
 614         context |= 1;
 615     else if (arg->arg_type == O_OR)
 616         context |= 2;
 617     if (context && arg[flp].arg_type == A_EXPR) {
 618         arg = arg[flp].arg_ptr.arg_arg;
 619         flp = 1;
 620     }
 621
 622     if (arg[flp].arg_flags & (AF_PRE|AF_POST)) {
 623         cmd->c_flags |= opt;
 624         return;                         /* side effect, can't optimize */
 625     }
 626
 627     if (arg->arg_type == O_ITEM || arg->arg_type == O_FLIP ||
 628       arg->arg_type == O_AND || arg->arg_type == O_OR) {
 629         if (arg[flp].arg_type == A_SINGLE) {
 630             opt = (str_true(arg[flp].arg_ptr.arg_str) ? CFT_TRUE : CFT_FALSE);
 631             cmd->c_short = arg[flp].arg_ptr.arg_str;
 632             goto literal;
 633         }
 634         else if (arg[flp].arg_type == A_STAB || arg[flp].arg_type == A_LVAL) {
 635             cmd->c_stab  = arg[flp].arg_ptr.arg_stab;
 636             opt = CFT_REG;
 637           literal:
 638             if (!context) {     /* no && or ||? */
 639                 free_arg(arg);
 640                 cmd->c_expr = Nullarg;
 641             }
 642             if (!(context & 1))
 643                 cmd->c_flags |= CF_EQSURE;
 644             if (!(context & 2))
 645                 cmd->c_flags |= CF_NESURE;
 646         }
 647     }
 648     else if (arg->arg_type == O_MATCH || arg->arg_type == O_SUBST ||
 649              arg->arg_type == O_NMATCH || arg->arg_type == O_NSUBST) {
 650         if ((arg[1].arg_type == A_STAB || arg[1].arg_type == A_LVAL) &&
 651                 arg[2].arg_type == A_SPAT &&
 652                 arg[2].arg_ptr.arg_spat->spat_short ) {
 653             cmd->c_stab  = arg[1].arg_ptr.arg_stab;
 654             cmd->c_short = arg[2].arg_ptr.arg_spat->spat_short;
 655             cmd->c_slen  = arg[2].arg_ptr.arg_spat->spat_slen;
 656             if (arg[2].arg_ptr.arg_spat->spat_flags & SPAT_ALL &&
 657                 !(arg[2].arg_ptr.arg_spat->spat_flags & SPAT_ONCE) &&
 658                 (arg->arg_type == O_MATCH || arg->arg_type == O_NMATCH) )
 659                 sure |= CF_EQSURE;              /* (SUBST must be forced even */
 660                                                 /* if we know it will work.) */
 661             arg[2].arg_ptr.arg_spat->spat_short = Nullstr;
 662             arg[2].arg_ptr.arg_spat->spat_slen = 0; /* only one chk */
 663             sure |= CF_NESURE;          /* normally only sure if it fails */
 664             if (arg->arg_type == O_NMATCH || arg->arg_type == O_NSUBST)
 665                 cmd->c_flags |= CF_FIRSTNEG;
 666             if (context & 1) {          /* only sure if thing is false */
 667                 if (cmd->c_flags & CF_FIRSTNEG)
 668                     sure &= ~CF_NESURE;
 669                 else
 670                     sure &= ~CF_EQSURE;
 671             }
 672             else if (context & 2) {     /* only sure if thing is true */
 673                 if (cmd->c_flags & CF_FIRSTNEG)
 674                     sure &= ~CF_EQSURE;
 675                 else
 676                     sure &= ~CF_NESURE;
 677             }
 678             if (sure & (CF_EQSURE|CF_NESURE)) { /* if we know anything*/
 679                 if (arg[2].arg_ptr.arg_spat->spat_flags & SPAT_SCANFIRST)
 680                     opt = CFT_SCAN;
 681                 else
 682                     opt = CFT_ANCHOR;
 683                 if (sure == (CF_EQSURE|CF_NESURE)       /* really sure? */
 684                     && arg->arg_type == O_MATCH
 685                     && context & 4
 686                     && fliporflop == 1) {
 687                     spat_free(arg[2].arg_ptr.arg_spat);
 688                     arg[2].arg_ptr.arg_spat = Nullspat; /* don't do twice */
 689                 }
 690                 cmd->c_flags |= sure;
 691             }
 692         }
 693     }
 694     else if (arg->arg_type == O_SEQ || arg->arg_type == O_SNE ||
 695              arg->arg_type == O_SLT || arg->arg_type == O_SGT) {
 696         if (arg[1].arg_type == A_STAB || arg[1].arg_type == A_LVAL) {
 697             if (arg[2].arg_type == A_SINGLE) {
 698                 cmd->c_stab  = arg[1].arg_ptr.arg_stab;
 699                 cmd->c_short = arg[2].arg_ptr.arg_str;
 700                 cmd->c_slen  = 30000;
 701                 switch (arg->arg_type) {
 702                 case O_SLT: case O_SGT:
 703                     sure |= CF_EQSURE;
 704                     cmd->c_flags |= CF_FIRSTNEG;
 705                     break;
 706                 case O_SNE:
 707                     cmd->c_flags |= CF_FIRSTNEG;
 708                     /* FALL THROUGH */
 709                 case O_SEQ:
 710                     sure |= CF_NESURE|CF_EQSURE;
 711                     break;
 712                 }
 713                 if (context & 1) {      /* only sure if thing is false */
 714                     if (cmd->c_flags & CF_FIRSTNEG)
 715                         sure &= ~CF_NESURE;
 716                     else
 717                         sure &= ~CF_EQSURE;
 718                 }
 719                 else if (context & 2) { /* only sure if thing is true */
 720                     if (cmd->c_flags & CF_FIRSTNEG)
 721                         sure &= ~CF_EQSURE;
 722                     else
 723                         sure &= ~CF_NESURE;
 724                 }
 725                 if (sure & (CF_EQSURE|CF_NESURE)) {
 726                     opt = CFT_STROP;
 727                     cmd->c_flags |= sure;
 728                 }
 729             }
 730         }
 731     }
 732     else if (arg->arg_type == O_EQ || arg->arg_type == O_NE ||
 733              arg->arg_type == O_LE || arg->arg_type == O_GE ||
 734              arg->arg_type == O_LT || arg->arg_type == O_GT) {
 735         if (arg[1].arg_type == A_STAB || arg[1].arg_type == A_LVAL) {
 736             if (arg[2].arg_type == A_SINGLE) {
 737                 cmd->c_stab  = arg[1].arg_ptr.arg_stab;
 738                 cmd->c_short = str_nmake(str_gnum(arg[2].arg_ptr.arg_str));
 739                 cmd->c_slen = arg->arg_type;
 740                 sure |= CF_NESURE|CF_EQSURE;
 741                 if (context & 1) {      /* only sure if thing is false */
 742                     sure &= ~CF_EQSURE;
 743                 }
 744                 else if (context & 2) { /* only sure if thing is true */
 745                     sure &= ~CF_NESURE;
 746                 }
 747                 if (sure & (CF_EQSURE|CF_NESURE)) {
 748                     opt = CFT_NUMOP;
 749                     cmd->c_flags |= sure;
 750                 }
 751             }
 752         }
 753     }
 754     else if (arg->arg_type == O_ASSIGN &&
 755              (arg[1].arg_type == A_STAB || arg[1].arg_type == A_LVAL) &&
 756              arg[1].arg_ptr.arg_stab == defstab &&
 757              arg[2].arg_type == A_EXPR ) {
 758         arg2 = arg[2].arg_ptr.arg_arg;
 759         if (arg2->arg_type == O_ITEM && arg2[1].arg_type == A_READ) {
 760             opt = CFT_GETS;
 761             cmd->c_stab = arg2[1].arg_ptr.arg_stab;
 762             if (!(arg2[1].arg_ptr.arg_stab->stab_io->flags & IOF_ARGV)) {
 763                 free_arg(arg2);
 764                 free_arg(arg);
 765                 cmd->c_expr = Nullarg;
 766             }
 767         }
 768     }
 769     else if (arg->arg_type == O_CHOP &&
 770              (arg[1].arg_type == A_STAB || arg[1].arg_type == A_LVAL) ) {
 771         opt = CFT_CHOP;
 772         cmd->c_stab = arg[1].arg_ptr.arg_stab;
 773         free_arg(arg);
 774         cmd->c_expr = Nullarg;
 775     }
 776     if (context & 4)
 777         opt |= CF_FLIP;
 778     cmd->c_flags |= opt;
 779
 780     if (cmd->c_flags & CF_FLIP) {
 781         if (fliporflop == 1) {
 782             arg = cmd->c_expr;  /* get back to O_FLIP arg */
 783             arg[3].arg_ptr.arg_cmd = (CMD*)safemalloc(sizeof(CMD));
 784             bcopy((char *)cmd, (char *)arg[3].arg_ptr.arg_cmd, sizeof(CMD));
 785             arg[4].arg_ptr.arg_cmd = (CMD*)safemalloc(sizeof(CMD));
 786             bcopy((char *)cmd, (char *)arg[4].arg_ptr.arg_cmd, sizeof(CMD));
 787             opt_arg(arg[4].arg_ptr.arg_cmd,2,acmd);
 788             arg->arg_len = 2;           /* this is a lie */
 789         }
 790         else {
 791             if ((opt & CF_OPTIMIZE) == CFT_EVAL)
 792                 cmd->c_flags = (cmd->c_flags & ~CF_OPTIMIZE) | CFT_UNFLIP;
 793         }
 794     }
 795 }
 796
 797 ARG *
 798 mod_match(type,left,pat)
 799 register ARG *left;
 800 register ARG *pat;
 801 {
 802
 803     register SPAT *spat;
 804     register ARG *newarg;
 805
 806     if ((pat->arg_type == O_MATCH ||
 807          pat->arg_type == O_SUBST ||
 808          pat->arg_type == O_TRANS ||
 809          pat->arg_type == O_SPLIT
 810         ) &&
 811         pat[1].arg_ptr.arg_stab == defstab ) {
 812         switch (pat->arg_type) {
 813         case O_MATCH:
 814             newarg = make_op(type == O_MATCH ? O_MATCH : O_NMATCH,
 815                 pat->arg_len,
 816                 left,Nullarg,Nullarg,0);
 817             break;
 818         case O_SUBST:
 819             newarg = l(make_op(type == O_MATCH ? O_SUBST : O_NSUBST,
 820                 pat->arg_len,
 821                 left,Nullarg,Nullarg,0));
 822             break;
 823         case O_TRANS:
 824             newarg = l(make_op(type == O_MATCH ? O_TRANS : O_NTRANS,
 825                 pat->arg_len,
 826                 left,Nullarg,Nullarg,0));
 827             break;
 828         case O_SPLIT:
 829             newarg = make_op(type == O_MATCH ? O_SPLIT : O_SPLIT,
 830                 pat->arg_len,
 831                 left,Nullarg,Nullarg,0);
 832             break;
 833         }
 834         if (pat->arg_len >= 2) {
 835             newarg[2].arg_type = pat[2].arg_type;
 836             newarg[2].arg_ptr = pat[2].arg_ptr;
 837             newarg[2].arg_flags = pat[2].arg_flags;
 838             if (pat->arg_len >= 3) {
 839                 newarg[3].arg_type = pat[3].arg_type;
 840                 newarg[3].arg_ptr = pat[3].arg_ptr;
 841                 newarg[3].arg_flags = pat[3].arg_flags;
 842             }
 843         }
 844         safefree((char*)pat);
 845     }
 846     else {
 847         spat = (SPAT *) safemalloc(sizeof (SPAT));
 848         bzero((char *)spat, sizeof(SPAT));
 849         spat->spat_next = spat_root;    /* link into spat list */
 850         spat_root = spat;
 851
 852         spat->spat_runtime = pat;
 853         newarg = make_op(type,2,left,Nullarg,Nullarg,0);
 854         newarg[2].arg_type = A_SPAT;
 855         newarg[2].arg_ptr.arg_spat = spat;
 856         newarg[2].arg_flags = AF_SPECIAL;
 857     }
 858
 859     return newarg;
 860 }
 861
 862 CMD *
 863 add_label(lbl,cmd)
 864 char *lbl;
 865 register CMD *cmd;
 866 {
 867     if (cmd)
 868         cmd->c_label = lbl;
 869     return cmd;
 870 }
 871
 872 CMD *
 873 addcond(cmd, arg)
 874 register CMD *cmd;
 875 register ARG *arg;
 876 {
 877     cmd->c_expr = arg;
 878     opt_arg(cmd,1,0);
 879     cmd->c_flags |= CF_COND;
 880     return cmd;
 881 }
 882
 883 CMD *
 884 addloop(cmd, arg)
 885 register CMD *cmd;
 886 register ARG *arg;
 887 {
 888     cmd->c_expr = arg;
 889     opt_arg(cmd,1,0);
 890     cmd->c_flags |= CF_COND|CF_LOOP;
 891     if (cmd->c_type == C_BLOCK)
 892         cmd->c_flags &= ~CF_COND;
 893     else {
 894         arg = cmd->ucmd.acmd.ac_expr;
 895         if (arg && arg->arg_type == O_ITEM && arg[1].arg_type == A_CMD)
 896             cmd->c_flags &= ~CF_COND;  /* "do {} while" happens at least once */
 897         if (arg && arg->arg_type == O_SUBR)
 898             cmd->c_flags &= ~CF_COND;  /* likewise for "do subr() while" */
 899     }
 900     return cmd;
 901 }
 902
 903 CMD *
 904 invert(cmd)
 905 register CMD *cmd;
 906 {
 907     cmd->c_flags ^= CF_INVERT;
 908     return cmd;
 909 }
 910
 911 yyerror(s)
 912 char *s;
 913 {
 914     char tmpbuf[128];
 915     char *tname = tmpbuf;
 916
 917     if (yychar > 256) {
 918         tname = tokename[yychar-256];
 919         if (strEQ(tname,"word"))
 920             strcpy(tname,tokenbuf);
 921         else if (strEQ(tname,"register"))
 922             sprintf(tname,"$%s",tokenbuf);
 923         else if (strEQ(tname,"array_length"))
 924             sprintf(tname,"$#%s",tokenbuf);
 925     }
 926     else if (!yychar)
 927         strcpy(tname,"EOF");
 928     else if (yychar < 32)
 929         sprintf(tname,"^%c",yychar+64);
 930     else if (yychar == 127)
 931         strcpy(tname,"^?");
 932     else
 933         sprintf(tname,"%c",yychar);
 934     sprintf(tokenbuf, "%s in file %s at line %d, next token \"%s\"\n",
 935       s,filename,line,tname);
 936     if (in_eval)
 937         str_set(stabent("@",TRUE)->stab_val,tokenbuf);
 938     else
 939         fputs(tokenbuf,stderr);
 940 }
 941
 942 ARG *
 943 make_op(type,newlen,arg1,arg2,arg3,dolist)
 944 int type;
 945 int newlen;
 946 ARG *arg1;
 947 ARG *arg2;
 948 ARG *arg3;
 949 int dolist;
 950 {
 951     register ARG *arg;
 952     register ARG *chld;
 953     register int doarg;
 954
 955     arg = op_new(newlen);
 956     arg->arg_type = type;
 957     doarg = opargs[type];
 958     if (chld = arg1) {
 959         if (!(doarg & 1))
 960             arg[1].arg_flags |= AF_SPECIAL;
 961         if (doarg & 16)
 962             arg[1].arg_flags |= AF_NUMERIC;
 963         if (chld->arg_type == O_ITEM &&
 964             (hoistable[chld[1].arg_type] || chld[1].arg_type == A_LVAL) ) {
 965             arg[1].arg_type = chld[1].arg_type;
 966             arg[1].arg_ptr = chld[1].arg_ptr;
 967             arg[1].arg_flags |= chld[1].arg_flags;
 968             free_arg(chld);
 969         }
 970         else {
 971             arg[1].arg_type = A_EXPR;
 972             arg[1].arg_ptr.arg_arg = chld;
 973             if (dolist & 1) {
 974                 if (chld->arg_type == O_LIST) {
 975                     if (newlen == 1) {  /* we can hoist entire list */
 976                         chld->arg_type = type;
 977                         free_arg(arg);
 978                         arg = chld;
 979                     }
 980                     else {
 981                         arg[1].arg_flags |= AF_SPECIAL;
 982                     }
 983                 }
 984                 else {
 985                     switch (chld->arg_type) {
 986                     case O_ARRAY:
 987                         if (chld->arg_len == 1)
 988                             arg[1].arg_flags |= AF_SPECIAL;
 989                         break;
 990                     case O_ITEM:
 991                         if (chld[1].arg_type == A_READ ||
 992                             chld[1].arg_type == A_INDREAD ||
 993                             chld[1].arg_type == A_GLOB)
 994                             arg[1].arg_flags |= AF_SPECIAL;
 995                         break;
 996                     case O_SPLIT:
 997                     case O_TMS:
 998                     case O_EACH:
 999                     case O_VALUES:
1000                     case O_KEYS:
1001                     case O_SORT:
1002                         arg[1].arg_flags |= AF_SPECIAL;
1003                         break;
1004                     }
1005                 }
1006             }
1007         }
1008     }
1009     if (chld = arg2) {
1010         if (!(doarg & 2))
1011             arg[2].arg_flags |= AF_SPECIAL;
1012         if (doarg & 32)
1013             arg[2].arg_flags |= AF_NUMERIC;
1014         if (chld->arg_type == O_ITEM &&
1015             (hoistable[chld[1].arg_type] ||
1016              (type == O_ASSIGN &&
1017               ((chld[1].arg_type == A_READ && !(arg[1].arg_flags & AF_SPECIAL))
1018                 ||
1019                (chld[1].arg_type == A_INDREAD && !(arg[1].arg_flags & AF_SPECIAL))
1020                 ||
1021                (chld[1].arg_type == A_GLOB && !(arg[1].arg_flags & AF_SPECIAL))
1022                 ||
1023                chld[1].arg_type == A_BACKTICK ) ) ) ) {
1024             arg[2].arg_type = chld[1].arg_type;
1025             arg[2].arg_ptr = chld[1].arg_ptr;
1026             free_arg(chld);
1027         }
1028         else {
1029             arg[2].arg_type = A_EXPR;
1030             arg[2].arg_ptr.arg_arg = chld;
1031             if ((dolist & 2) &&
1032               (chld->arg_type == O_LIST ||
1033                (chld->arg_type == O_ARRAY && chld->arg_len == 1) ))
1034                 arg[2].arg_flags |= AF_SPECIAL;
1035         }
1036     }
1037     if (chld = arg3) {
1038         if (!(doarg & 4))
1039             arg[3].arg_flags |= AF_SPECIAL;
1040         if (doarg & 64)
1041             arg[3].arg_flags |= AF_NUMERIC;
1042         if (chld->arg_type == O_ITEM && hoistable[chld[1].arg_type]) {
1043             arg[3].arg_type = chld[1].arg_type;
1044             arg[3].arg_ptr = chld[1].arg_ptr;
1045             free_arg(chld);
1046         }
1047         else {
1048             arg[3].arg_type = A_EXPR;
1049             arg[3].arg_ptr.arg_arg = chld;
1050             if ((dolist & 4) &&
1051               (chld->arg_type == O_LIST ||
1052                (chld->arg_type == O_ARRAY && chld->arg_len == 1) ))
1053                 arg[3].arg_flags |= AF_SPECIAL;
1054         }
1055     }
1056 #ifdef DEBUGGING
1057     if (debug & 16) {
1058         fprintf(stderr,"%lx <= make_op(%s",arg,opname[arg->arg_type]);
1059         if (arg1)
1060             fprintf(stderr,",%s=%lx",
1061                 argname[arg[1].arg_type],arg[1].arg_ptr.arg_arg);
1062         if (arg2)
1063             fprintf(stderr,",%s=%lx",
1064                 argname[arg[2].arg_type],arg[2].arg_ptr.arg_arg);
1065         if (arg3)
1066             fprintf(stderr,",%s=%lx",
1067                 argname[arg[3].arg_type],arg[3].arg_ptr.arg_arg);
1068         fprintf(stderr,")\n");
1069     }
1070 #endif
1071     evalstatic(arg);            /* see if we can consolidate anything */
1072     return arg;
1073 }
1074
1075 /* turn 123 into 123 == $. */
1076
1077 ARG *
1078 flipflip(arg)
1079 register ARG *arg;
1080 {
1081     if (arg && arg->arg_type == O_ITEM && arg[1].arg_type == A_SINGLE) {
1082         arg = (ARG*)saferealloc((char*)arg,3*sizeof(ARG));
1083         arg->arg_type = O_EQ;
1084         arg->arg_len = 2;
1085         arg[2].arg_type = A_STAB;
1086         arg[2].arg_flags = 0;
1087         arg[2].arg_ptr.arg_stab = stabent(".",TRUE);
1088     }
1089     return arg;
1090 }
1091
1092 void
1093 evalstatic(arg)
1094 register ARG *arg;
1095 {
1096     register STR *str;
1097     register STR *s1;
1098     register STR *s2;
1099     double value;               /* must not be register */
1100     register char *tmps;
1101     int i;
1102     unsigned long tmplong;
1103     double exp(), log(), sqrt(), modf();
1104     char *crypt();
1105
1106     if (!arg || !arg->arg_len)
1107         return;
1108
1109     if (arg[1].arg_type == A_SINGLE &&
1110         (arg->arg_len == 1 || arg[2].arg_type == A_SINGLE) ) {
1111         str = str_new(0);
1112         s1 = arg[1].arg_ptr.arg_str;
1113         if (arg->arg_len > 1)
1114             s2 = arg[2].arg_ptr.arg_str;
1115         else
1116             s2 = Nullstr;
1117         switch (arg->arg_type) {
1118         default:
1119             str_free(str);
1120             str = Nullstr;              /* can't be evaluated yet */
1121             break;
1122         case O_CONCAT:
1123             str_sset(str,s1);
1124             str_scat(str,s2);
1125             break;
1126         case O_REPEAT:
1127             i = (int)str_gnum(s2);
1128             while (i-- > 0)
1129                 str_scat(str,s1);
1130             break;
1131         case O_MULTIPLY:
1132             value = str_gnum(s1);
1133             str_numset(str,value * str_gnum(s2));
1134             break;
1135         case O_DIVIDE:
1136             value = str_gnum(s2);
1137             if (value == 0.0)
1138                 fatal("Illegal division by constant zero");
1139             str_numset(str,str_gnum(s1) / value);
1140             break;
1141         case O_MODULO:
1142             tmplong = (unsigned long)str_gnum(s2);
1143             if (tmplong == 0L)
1144                 fatal("Illegal modulus of constant zero");
1145             str_numset(str,(double)(((unsigned long)str_gnum(s1)) % tmplong));
1146             break;
1147         case O_ADD:
1148             value = str_gnum(s1);
1149             str_numset(str,value + str_gnum(s2));
1150             break;
1151         case O_SUBTRACT:
1152             value = str_gnum(s1);
1153             str_numset(str,value - str_gnum(s2));
1154             break;
1155         case O_LEFT_SHIFT:
1156             value = str_gnum(s1);
1157             i = (int)str_gnum(s2);
1158             str_numset(str,(double)(((unsigned long)value) << i));
1159             break;
1160         case O_RIGHT_SHIFT:
1161             value = str_gnum(s1);
1162             i = (int)str_gnum(s2);
1163             str_numset(str,(double)(((unsigned long)value) >> i));
1164             break;
1165         case O_LT:
1166             value = str_gnum(s1);
1167             str_numset(str,(double)(value < str_gnum(s2)));
1168             break;
1169         case O_GT:
1170             value = str_gnum(s1);
1171             str_numset(str,(double)(value > str_gnum(s2)));
1172             break;
1173         case O_LE:
1174             value = str_gnum(s1);
1175             str_numset(str,(double)(value <= str_gnum(s2)));
1176             break;
1177         case O_GE:
1178             value = str_gnum(s1);
1179             str_numset(str,(double)(value >= str_gnum(s2)));
1180             break;
1181         case O_EQ:
1182             value = str_gnum(s1);
1183             str_numset(str,(double)(value == str_gnum(s2)));
1184             break;
1185         case O_NE:
1186             value = str_gnum(s1);
1187             str_numset(str,(double)(value != str_gnum(s2)));
1188             break;
1189         case O_BIT_AND:
1190             value = str_gnum(s1);
1191             str_numset(str,(double)(((unsigned long)value) &
1192                 ((unsigned long)str_gnum(s2))));
1193             break;
1194         case O_XOR:
1195             value = str_gnum(s1);
1196             str_numset(str,(double)(((unsigned long)value) ^
1197                 ((unsigned long)str_gnum(s2))));
1198             break;
1199         case O_BIT_OR:
1200             value = str_gnum(s1);
1201             str_numset(str,(double)(((unsigned long)value) |
1202                 ((unsigned long)str_gnum(s2))));
1203             break;
1204         case O_AND:
1205             if (str_true(s1))
1206                 str = str_make(str_get(s2));
1207             else
1208                 str = str_make(str_get(s1));
1209             break;
1210         case O_OR:
1211             if (str_true(s1))
1212                 str = str_make(str_get(s1));
1213             else
1214                 str = str_make(str_get(s2));
1215             break;
1216         case O_COND_EXPR:
1217             if (arg[3].arg_type != A_SINGLE) {
1218                 str_free(str);
1219                 str = Nullstr;
1220             }
1221             else {
1222                 str = str_make(str_get(str_true(s1) ? s2 : arg[3].arg_ptr.arg_str));
1223                 str_free(arg[3].arg_ptr.arg_str);
1224             }
1225             break;
1226         case O_NEGATE:
1227             str_numset(str,(double)(-str_gnum(s1)));
1228             break;
1229         case O_NOT:
1230             str_numset(str,(double)(!str_true(s1)));
1231             break;
1232         case O_COMPLEMENT:
1233             str_numset(str,(double)(~(long)str_gnum(s1)));
1234             break;
1235         case O_LENGTH:
1236             str_numset(str, (double)str_len(s1));
1237             break;
1238         case O_SUBSTR:
1239             if (arg[3].arg_type != A_SINGLE || stabent("[",allstabs)) {
1240                 str_free(str);          /* making the fallacious assumption */
1241                 str = Nullstr;          /* that any $[ occurs before substr()*/
1242             }
1243             else {
1244                 char *beg;
1245                 int len = (int)str_gnum(s2);
1246                 int tmp;
1247
1248                 for (beg = str_get(s1); *beg && len > 0; beg++,len--) ;
1249                 len = (int)str_gnum(arg[3].arg_ptr.arg_str);
1250                 str_free(arg[3].arg_ptr.arg_str);
1251                 if (len > (tmp = strlen(beg)))
1252                     len = tmp;
1253                 str_nset(str,beg,len);
1254             }
1255             break;
1256         case O_SLT:
1257             tmps = str_get(s1);
1258             str_numset(str,(double)(strLT(tmps,str_get(s2))));
1259             break;
1260         case O_SGT:
1261             tmps = str_get(s1);
1262             str_numset(str,(double)(strGT(tmps,str_get(s2))));
1263             break;
1264         case O_SLE:
1265             tmps = str_get(s1);
1266             str_numset(str,(double)(strLE(tmps,str_get(s2))));
1267             break;
1268         case O_SGE:
1269             tmps = str_get(s1);
1270             str_numset(str,(double)(strGE(tmps,str_get(s2))));
1271             break;
1272         case O_SEQ:
1273             tmps = str_get(s1);
1274             str_numset(str,(double)(strEQ(tmps,str_get(s2))));
1275             break;
1276         case O_SNE:
1277             tmps = str_get(s1);
1278             str_numset(str,(double)(strNE(tmps,str_get(s2))));
1279             break;
1280         case O_CRYPT:
1281 #ifdef CRYPT
1282             tmps = str_get(s1);
1283             str_set(str,crypt(tmps,str_get(s2)));
1284 #else
1285             fatal(
1286             "The crypt() function is unimplemented due to excessive paranoia.");
1287 #endif
1288             break;
1289         case O_EXP:
1290             str_numset(str,exp(str_gnum(s1)));
1291             break;
1292         case O_LOG:
1293             str_numset(str,log(str_gnum(s1)));
1294             break;
1295         case O_SQRT:
1296             str_numset(str,sqrt(str_gnum(s1)));
1297             break;
1298         case O_INT:
1299             value = str_gnum(s1);
1300             if (value >= 0.0)
1301                 modf(value,&value);
1302             else {
1303                 modf(-value,&value);
1304                 value = -value;
1305             }
1306             str_numset(str,value);
1307             break;
1308         case O_ORD:
1309             str_numset(str,(double)(*str_get(s1)));
1310             break;
1311         }
1312         if (str) {
1313             arg->arg_type = O_ITEM;     /* note arg1 type is already SINGLE */
1314             str_free(s1);
1315             str_free(s2);
1316             arg[1].arg_ptr.arg_str = str;
1317         }
1318     }
1319 }
1320
1321 ARG *
1322 l(arg)
1323 register ARG *arg;
1324 {
1325     register int i;
1326     register ARG *arg1;
1327     ARG *tmparg;
1328
1329     arg->arg_flags |= AF_COMMON;        /* XXX should cross-match */
1330                                         /* this does unnecessary copying */
1331
1332     if (arg[1].arg_type == A_ARYLEN) {
1333         arg[1].arg_type = A_LARYLEN;
1334         return arg;
1335     }
1336
1337     /* see if it's an array reference */
1338
1339     if (arg[1].arg_type == A_EXPR) {
1340         arg1 = arg[1].arg_ptr.arg_arg;
1341
1342         if (arg1->arg_type == O_LIST && arg->arg_type != O_ITEM) {
1343                                                 /* assign to list */
1344             arg[1].arg_flags |= AF_SPECIAL;
1345             dehoist(arg,2);
1346             arg[2].arg_flags |= AF_SPECIAL;
1347             for (i = arg1->arg_len; i >= 1; i--) {
1348                 switch (arg1[i].arg_type) {
1349                 case A_STAB: case A_LVAL:
1350                     arg1[i].arg_type = A_LVAL;
1351                     break;
1352                 case A_EXPR: case A_LEXPR:
1353                     arg1[i].arg_type = A_LEXPR;
1354                     if (arg1[i].arg_ptr.arg_arg->arg_type == O_ARRAY)
1355                         arg1[i].arg_ptr.arg_arg->arg_type = O_LARRAY;
1356                     else if (arg1[i].arg_ptr.arg_arg->arg_type == O_HASH)
1357                         arg1[i].arg_ptr.arg_arg->arg_type = O_LHASH;
1358                     if (arg1[i].arg_ptr.arg_arg->arg_type == O_LARRAY)
1359                         break;
1360                     if (arg1[i].arg_ptr.arg_arg->arg_type == O_LHASH)
1361                         break;
1362                     /* FALL THROUGH */
1363                 default:
1364                     sprintf(tokenbuf,
1365                       "Illegal item (%s) as lvalue",argname[arg1[i].arg_type]);
1366                     yyerror(tokenbuf);
1367                 }
1368             }
1369         }
1370         else if (arg1->arg_type == O_ARRAY) {
1371             if (arg1->arg_len == 1 && arg->arg_type != O_ITEM) {
1372                                                 /* assign to array */
1373                 arg[1].arg_flags |= AF_SPECIAL;
1374                 dehoist(arg,2);
1375                 arg[2].arg_flags |= AF_SPECIAL;
1376             }
1377             else
1378                 arg1->arg_type = O_LARRAY;      /* assign to array elem */
1379         }
1380         else if (arg1->arg_type == O_HASH)
1381             arg1->arg_type = O_LHASH;
1382         else if (arg1->arg_type != O_ASSIGN) {
1383             sprintf(tokenbuf,
1384               "Illegal expression (%s) as lvalue",opname[arg1->arg_type]);
1385             yyerror(tokenbuf);
1386         }
1387         arg[1].arg_type = A_LEXPR;
1388 #ifdef DEBUGGING
1389         if (debug & 16)
1390             fprintf(stderr,"lval LEXPR\n");
1391 #endif
1392         return arg;
1393     }
1394
1395     /* not an array reference, should be a register name */
1396
1397     if (arg[1].arg_type != A_STAB && arg[1].arg_type != A_LVAL) {
1398         sprintf(tokenbuf,
1399           "Illegal item (%s) as lvalue",argname[arg[1].arg_type]);
1400         yyerror(tokenbuf);
1401     }
1402     arg[1].arg_type = A_LVAL;
1403 #ifdef DEBUGGING
1404     if (debug & 16)
1405         fprintf(stderr,"lval LVAL\n");
1406 #endif
1407     return arg;
1408 }
1409
1410 dehoist(arg,i)
1411 ARG *arg;
1412 {
1413     ARG *tmparg;
1414
1415     if (arg[i].arg_type != A_EXPR) {    /* dehoist */
1416         tmparg = make_op(O_ITEM,1,Nullarg,Nullarg,Nullarg,0);
1417         tmparg[1] = arg[i];
1418         arg[i].arg_ptr.arg_arg = tmparg;
1419         arg[i].arg_type = A_EXPR;
1420     }
1421 }
1422
1423 ARG *
1424 addflags(i,flags,arg)
1425 register ARG *arg;
1426 {
1427     arg[i].arg_flags |= flags;
1428     return arg;
1429 }
1430
1431 ARG *
1432 hide_ary(arg)
1433 ARG *arg;
1434 {
1435     if (arg->arg_type == O_ARRAY)
1436         return make_op(O_ITEM,1,arg,Nullarg,Nullarg,0);
1437     return arg;
1438 }
1439
1440 ARG *
1441 make_list(arg)
1442 register ARG *arg;
1443 {
1444     register int i;
1445     register ARG *node;
1446     register ARG *nxtnode;
1447     register int j;
1448     STR *tmpstr;
1449
1450     if (!arg) {
1451         arg = op_new(0);
1452         arg->arg_type = O_LIST;
1453     }
1454     if (arg->arg_type != O_COMMA) {
1455         arg->arg_flags |= AF_LISTISH;   /* see listish() below */
1456         return arg;
1457     }
1458     for (i = 2, node = arg; ; i++) {
1459         if (node->arg_len < 2)
1460             break;
1461         if (node[2].arg_type != A_EXPR)
1462             break;
1463         node = node[2].arg_ptr.arg_arg;
1464         if (node->arg_type != O_COMMA)
1465             break;
1466     }
1467     if (i > 2) {
1468         node = arg;
1469         arg = op_new(i);
1470         tmpstr = arg->arg_ptr.arg_str;
1471         *arg = *node;           /* copy everything except the STR */
1472         arg->arg_ptr.arg_str = tmpstr;
1473         for (j = 1; ; ) {
1474             arg[j] = node[1];
1475             ++j;                /* Bug in Xenix compiler */
1476             if (j >= i) {
1477                 arg[j] = node[2];
1478                 free_arg(node);
1479                 break;
1480             }
1481             nxtnode = node[2].arg_ptr.arg_arg;
1482             free_arg(node);
1483             node = nxtnode;
1484         }
1485     }
1486     arg->arg_type = O_LIST;
1487     arg->arg_len = i;
1488     return arg;
1489 }
1490
1491 /* turn a single item into a list */
1492
1493 ARG *
1494 listish(arg)
1495 ARG *arg;
1496 {
1497     if (arg->arg_flags & AF_LISTISH) {
1498         arg = make_op(O_LIST,1,arg,Nullarg,Nullarg,0);
1499         arg[1].arg_flags &= ~AF_SPECIAL;
1500     }
1501     return arg;
1502 }
1503
1504 /* mark list of local variables */
1505
1506 ARG *
1507 localize(arg)
1508 ARG *arg;
1509 {
1510     arg->arg_flags |= AF_LOCAL;
1511     return arg;
1512 }
1513
1514 ARG *
1515 stab2arg(atype,stab)
1516 int atype;
1517 register STAB *stab;
1518 {
1519     register ARG *arg;
1520
1521     arg = op_new(1);
1522     arg->arg_type = O_ITEM;
1523     arg[1].arg_type = atype;
1524     arg[1].arg_ptr.arg_stab = stab;
1525     return arg;
1526 }
1527
1528 ARG *
1529 cval_to_arg(cval)
1530 register char *cval;
1531 {
1532     register ARG *arg;
1533
1534     arg = op_new(1);
1535     arg->arg_type = O_ITEM;
1536     arg[1].arg_type = A_SINGLE;
1537     arg[1].arg_ptr.arg_str = str_make(cval);
1538     safefree(cval);
1539     return arg;
1540 }
1541
1542 ARG *
1543 op_new(numargs)
1544 int numargs;
1545 {
1546     register ARG *arg;
1547
1548     arg = (ARG*)safemalloc((numargs + 1) * sizeof (ARG));
1549     bzero((char *)arg, (numargs + 1) * sizeof (ARG));
1550     arg->arg_ptr.arg_str = str_new(0);
1551     arg->arg_len = numargs;
1552     return arg;
1553 }
1554
1555 void
1556 free_arg(arg)
1557 ARG *arg;
1558 {
1559     str_free(arg->arg_ptr.arg_str);
1560     safefree((char*)arg);
1561 }
1562
1563 ARG *
1564 make_match(type,expr,spat)
1565 int type;
1566 ARG *expr;
1567 SPAT *spat;
1568 {
1569     register ARG *arg;
1570
1571     arg = make_op(type,2,expr,Nullarg,Nullarg,0);
1572
1573     arg[2].arg_type = A_SPAT;
1574     arg[2].arg_ptr.arg_spat = spat;
1575 #ifdef DEBUGGING
1576     if (debug & 16)
1577         fprintf(stderr,"make_match SPAT=%lx\n",(long)spat);
1578 #endif
1579
1580     if (type == O_SUBST || type == O_NSUBST) {
1581         if (arg[1].arg_type != A_STAB)
1582             yyerror("Illegal lvalue");
1583         arg[1].arg_type = A_LVAL;
1584     }
1585     return arg;
1586 }
1587
1588 ARG *
1589 cmd_to_arg(cmd)
1590 CMD *cmd;
1591 {
1592     register ARG *arg;
1593
1594     arg = op_new(1);
1595     arg->arg_type = O_ITEM;
1596     arg[1].arg_type = A_CMD;
1597     arg[1].arg_ptr.arg_cmd = cmd;
1598     return arg;
1599 }
1600
1601 CMD *
1602 wopt(cmd)
1603 register CMD *cmd;
1604 {
1605     register CMD *tail;
1606     register ARG *arg = cmd->c_expr;
1607     STAB *asgnstab;
1608
1609     /* hoist "while (<channel>)" up into command block */
1610
1611     if (arg && arg->arg_type == O_ITEM && arg[1].arg_type == A_READ) {
1612         cmd->c_flags &= ~CF_OPTIMIZE;   /* clear optimization type */
1613         cmd->c_flags |= CFT_GETS;       /* and set it to do the input */
1614         cmd->c_stab = arg[1].arg_ptr.arg_stab;
1615         if (arg[1].arg_ptr.arg_stab->stab_io->flags & IOF_ARGV) {
1616             cmd->c_expr = l(make_op(O_ASSIGN, 2,        /* fake up "$_ =" */
1617                stab2arg(A_LVAL,defstab), arg, Nullarg,1 ));
1618         }
1619         else {
1620             free_arg(arg);
1621             cmd->c_expr = Nullarg;
1622         }
1623     }
1624     else if (arg && arg->arg_type == O_ITEM && arg[1].arg_type == A_INDREAD) {
1625         cmd->c_flags &= ~CF_OPTIMIZE;   /* clear optimization type */
1626         cmd->c_flags |= CFT_INDGETS;    /* and set it to do the input */
1627         cmd->c_stab = arg[1].arg_ptr.arg_stab;
1628         free_arg(arg);
1629         cmd->c_expr = Nullarg;
1630     }
1631     else if (arg && arg->arg_type == O_ITEM && arg[1].arg_type == A_GLOB) {
1632         if ((cmd->c_flags & CF_OPTIMIZE) == CFT_ARRAY)
1633             asgnstab = cmd->c_stab;
1634         else
1635             asgnstab = defstab;
1636         cmd->c_expr = l(make_op(O_ASSIGN, 2,    /* fake up "$foo =" */
1637            stab2arg(A_LVAL,asgnstab), arg, Nullarg,1 ));
1638         cmd->c_flags &= ~CF_OPTIMIZE;   /* clear optimization type */
1639     }
1640
1641     /* First find the end of the true list */
1642
1643     if (cmd->ucmd.ccmd.cc_true == Nullcmd)
1644         return cmd;
1645     for (tail = cmd->ucmd.ccmd.cc_true; tail->c_next; tail = tail->c_next) ;
1646
1647     /* if there's a continue block, link it to true block and find end */
1648
1649     if (cmd->ucmd.ccmd.cc_alt != Nullcmd) {
1650         tail->c_next = cmd->ucmd.ccmd.cc_alt;
1651         for ( ; tail->c_next; tail = tail->c_next) ;
1652     }
1653
1654     /* Here's the real trick: link the end of the list back to the beginning,
1655      * inserting a "last" block to break out of the loop.  This saves one or
1656      * two procedure calls every time through the loop, because of how cmd_exec
1657      * does tail recursion.
1658      */
1659
1660     tail->c_next = (CMD *) safemalloc(sizeof (CMD));
1661     tail = tail->c_next;
1662     if (!cmd->ucmd.ccmd.cc_alt)
1663         cmd->ucmd.ccmd.cc_alt = tail;   /* every loop has a continue now */
1664
1665     bcopy((char *)cmd, (char *)tail, sizeof(CMD));
1666     tail->c_type = C_EXPR;
1667     tail->c_flags ^= CF_INVERT;         /* turn into "last unless" */
1668     tail->c_next = tail->ucmd.ccmd.cc_true;     /* loop directly back to top */
1669     tail->ucmd.acmd.ac_expr = make_op(O_LAST,0,Nullarg,Nullarg,Nullarg,0);
1670     tail->ucmd.acmd.ac_stab = Nullstab;
1671     return cmd;
1672 }
1673
1674 CMD *
1675 over(eachstab,cmd)
1676 STAB *eachstab;
1677 register CMD *cmd;
1678 {
1679     /* hoist "for $foo (@bar)" up into command block */
1680
1681     cmd->c_flags &= ~CF_OPTIMIZE;       /* clear optimization type */
1682     cmd->c_flags |= CFT_ARRAY;          /* and set it to do the iteration */
1683     cmd->c_stab = eachstab;
1684
1685     return cmd;
1686 }
1687
1688 static int gensym = 0;
1689
1690 STAB *
1691 genstab()
1692 {
1693     sprintf(tokenbuf,"_GEN_%d",gensym++);
1694     return stabent(tokenbuf,TRUE);
1695 }
1696
1697 /* this routine is in perly.c by virtue of being sort of an alternate main() */
1698
1699 STR *
1700 do_eval(str,optype)
1701 STR *str;
1702 int optype;
1703 {
1704     int retval;
1705     CMD *myroot;
1706     ARRAY *ar;
1707     int i;
1708     char *oldfile = filename;
1709     line_t oldline = line;
1710     int oldtmps_base = tmps_base;
1711     int oldsave = savestack->ary_fill;
1712
1713     tmps_base = tmps_max;
1714     str_set(stabent("@",TRUE)->stab_val,"");
1715     if (optype != O_DOFILE) {   /* normal eval */
1716         filename = "(eval)";
1717         line = 1;
1718         str_sset(linestr,str);
1719     }
1720     else {
1721         filename = savestr(str_get(str));       /* can't free this easily */
1722         str_set(linestr,"");
1723         rsfp = fopen(filename,"r");
1724         ar = incstab->stab_array;
1725         if (!rsfp && *filename != '/') {
1726             for (i = 0; i <= ar->ary_fill; i++) {
1727                 sprintf(tokenbuf,"%s/%s",str_get(afetch(ar,i)),filename);
1728                 rsfp = fopen(tokenbuf,"r");
1729                 if (rsfp) {
1730                     free(filename);
1731                     filename = savestr(tokenbuf);
1732                     break;
1733                 }
1734             }
1735         }
1736         if (!rsfp) {
1737             filename = oldfile;
1738             tmps_base = oldtmps_base;
1739             return &str_no;
1740         }
1741         line = 0;
1742     }
1743     in_eval++;
1744     bufptr = str_get(linestr);
1745     if (setjmp(eval_env))
1746         retval = 1;
1747     else
1748         retval = yyparse();
1749     myroot = eval_root;         /* in case cmd_exec does another eval! */
1750     if (retval)
1751         str = &str_no;
1752     else {
1753         str = str_static(cmd_exec(eval_root));
1754                                 /* if we don't save str, free zaps it */
1755         cmd_free(myroot);       /* can't free on error, for some reason */
1756     }
1757     in_eval--;
1758     filename = oldfile;
1759     line = oldline;
1760     tmps_base = oldtmps_base;
1761     if (savestack->ary_fill > oldsave)  /* let them use local() */
1762         restorelist(oldsave);
1763     return str;
1764 }
1765
1766 cmd_free(cmd)
1767 register CMD *cmd;
1768 {
1769     register CMD *tofree;
1770     register CMD *head = cmd;
1771
1772     while (cmd) {
1773         if (cmd->c_type != C_WHILE) {   /* WHILE block is duplicated */
1774             if (cmd->c_label)
1775                 safefree(cmd->c_label);
1776             if (cmd->c_short)
1777                 str_free(cmd->c_short);
1778             if (cmd->c_spat)
1779                 spat_free(cmd->c_spat);
1780             if (cmd->c_expr)
1781                 arg_free(cmd->c_expr);
1782         }
1783         switch (cmd->c_type) {
1784         case C_WHILE:
1785         case C_BLOCK:
1786         case C_IF:
1787             if (cmd->ucmd.ccmd.cc_true)
1788                 cmd_free(cmd->ucmd.ccmd.cc_true);
1789             if (cmd->c_type == C_IF && cmd->ucmd.ccmd.cc_alt)
1790                 cmd_free(cmd->ucmd.ccmd.cc_alt);
1791             break;
1792         case C_EXPR:
1793             if (cmd->ucmd.acmd.ac_expr)
1794                 arg_free(cmd->ucmd.acmd.ac_expr);
1795             break;
1796         }
1797         tofree = cmd;
1798         cmd = cmd->c_next;
1799         safefree((char*)tofree);
1800         if (cmd && cmd == head)         /* reached end of while loop */
1801             break;
1802     }
1803 }
1804
1805 arg_free(arg)
1806 register ARG *arg;
1807 {
1808     register int i;
1809
1810     for (i = 1; i <= arg->arg_len; i++) {
1811         switch (arg[i].arg_type) {
1812         case A_NULL:
1813             break;
1814         case A_LEXPR:
1815         case A_EXPR:
1816             arg_free(arg[i].arg_ptr.arg_arg);
1817             break;
1818         case A_CMD:
1819             cmd_free(arg[i].arg_ptr.arg_cmd);
1820             break;
1821         case A_WORD:
1822         case A_STAB:
1823         case A_LVAL:
1824         case A_READ:
1825         case A_GLOB:
1826         case A_ARYLEN:
1827             break;
1828         case A_SINGLE:
1829         case A_DOUBLE:
1830         case A_BACKTICK:
1831             str_free(arg[i].arg_ptr.arg_str);
1832             break;
1833         case A_SPAT:
1834             spat_free(arg[i].arg_ptr.arg_spat);
1835             break;
1836         case A_NUMBER:
1837             break;
1838         }
1839     }
1840     free_arg(arg);
1841 }
1842
1843 spat_free(spat)
1844 register SPAT *spat;
1845 {
1846     register SPAT *sp;
1847
1848     if (spat->spat_runtime)
1849         arg_free(spat->spat_runtime);
1850     if (spat->spat_repl) {
1851         arg_free(spat->spat_repl);
1852     }
1853     if (spat->spat_short) {
1854         str_free(spat->spat_short);
1855     }
1856     if (spat->spat_regexp) {
1857         regfree(spat->spat_regexp);
1858     }
1859
1860     /* now unlink from spat list */
1861     if (spat_root == spat)
1862         spat_root = spat->spat_next;
1863     else {
1864         for (sp = spat_root; sp->spat_next != spat; sp = sp->spat_next) ;
1865         sp->spat_next = spat->spat_next;
1866     }
1867
1868     safefree((char*)spat);
1869 }
1870
1871 /* Recursively descend a command sequence and push the address of any string
1872  * that needs saving on recursion onto the tosave array.
1873  */
1874
1875 static int
1876 cmd_tosave(cmd)
1877 register CMD *cmd;
1878 {
1879     register CMD *head = cmd;
1880
1881     while (cmd) {
1882         if (cmd->c_spat)
1883             spat_tosave(cmd->c_spat);
1884         if (cmd->c_expr)
1885             arg_tosave(cmd->c_expr);
1886         switch (cmd->c_type) {
1887         case C_WHILE:
1888         case C_BLOCK:
1889         case C_IF:
1890             if (cmd->ucmd.ccmd.cc_true)
1891                 cmd_tosave(cmd->ucmd.ccmd.cc_true);
1892             if (cmd->c_type == C_IF && cmd->ucmd.ccmd.cc_alt)
1893                 cmd_tosave(cmd->ucmd.ccmd.cc_alt);
1894             break;
1895         case C_EXPR:
1896             if (cmd->ucmd.acmd.ac_expr)
1897                 arg_tosave(cmd->ucmd.acmd.ac_expr);
1898             break;
1899         }
1900         cmd = cmd->c_next;
1901         if (cmd && cmd == head)         /* reached end of while loop */
1902             break;
1903     }
1904 }
1905
1906 static int
1907 arg_tosave(arg)
1908 register ARG *arg;
1909 {
1910     register int i;
1911     int saving = FALSE;
1912
1913     for (i = 1; i <= arg->arg_len; i++) {
1914         switch (arg[i].arg_type) {
1915         case A_NULL:
1916             break;
1917         case A_LEXPR:
1918         case A_EXPR:
1919             saving |= arg_tosave(arg[i].arg_ptr.arg_arg);
1920             break;
1921         case A_CMD:
1922             cmd_tosave(arg[i].arg_ptr.arg_cmd);
1923             saving = TRUE;      /* assume hanky panky */
1924             break;
1925         case A_WORD:
1926         case A_STAB:
1927         case A_LVAL:
1928         case A_READ:
1929         case A_GLOB:
1930         case A_ARYLEN:
1931         case A_SINGLE:
1932         case A_DOUBLE:
1933         case A_BACKTICK:
1934             break;
1935         case A_SPAT:
1936             saving |= spat_tosave(arg[i].arg_ptr.arg_spat);
1937             break;
1938         case A_NUMBER:
1939             break;
1940         }
1941     }
1942     switch (arg->arg_type) {
1943     case O_EVAL:
1944     case O_SUBR:
1945         saving = TRUE;
1946     }
1947     if (saving)
1948         apush(tosave,arg->arg_ptr.arg_str);
1949     return saving;
1950 }
1951
1952 static int
1953 spat_tosave(spat)
1954 register SPAT *spat;
1955 {
1956     int saving = FALSE;
1957
1958     if (spat->spat_runtime)
1959         saving |= arg_tosave(spat->spat_runtime);
1960     if (spat->spat_repl) {
1961         saving |= arg_tosave(spat->spat_repl);
1962     }
1963
1964     return saving;
1965 }