perly.c

   1 char rcsid[] = "$Header: perly.c,v 3.0 89/10/18 15:22:21 lwall Locked $\nPatch level: ###\n";
   2 /*
   3  *    Copyright (c) 1989, Larry Wall
   4  *
   5  *    You may distribute under the terms of the GNU General Public License
   6  *    as specified in the README file that comes with the perl 3.0 kit.
   7  *
   8  * $Log:        perly.c,v $
   9  * Revision 3.0  89/10/18  15:22:21  lwall
  10  * 3.0 baseline
  11  *
  12  */
  13
  14 #include "EXTERN.h"
  15 #include "perl.h"
  16 #include "perly.h"
  17 #include "patchlevel.h"
  18
  19 #ifdef IAMSUID
  20 #ifndef DOSUID
  21 #define DOSUID
  22 #endif
  23 #endif
  24
  25 #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
  26 #ifdef DOSUID
  27 #undef DOSUID
  28 #endif
  29 #endif
  30
  31 main(argc,argv,env)
  32 register int argc;
  33 register char **argv;
  34 register char **env;
  35 {
  36     register STR *str;
  37     register char *s;
  38     char *index(), *strcpy(), *getenv();
  39     bool dosearch = FALSE;
  40     char **origargv = argv;
  41 #ifdef DOSUID
  42     char *validarg = "";
  43 #endif
  44
  45 #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
  46 #ifdef IAMSUID
  47 #undef IAMSUID
  48     fatal("suidperl is no longer needed since the kernel can now execute\n\
  49 setuid perl scripts securely.\n");
  50 #endif
  51 #endif
  52
  53     uid = (int)getuid();
  54     euid = (int)geteuid();
  55     gid = (int)getgid();
  56     egid = (int)getegid();
  57     if (do_undump) {
  58         do_undump = 0;
  59         loop_ptr = 0;           /* start label stack again */
  60         goto just_doit;
  61     }
  62     (void)sprintf(index(rcsid,'#'), "%d\n", PATCHLEVEL);
  63     linestr = Str_new(65,80);
  64     str_nset(linestr,"",0);
  65     str = str_make("",0);               /* first used for -I flags */
  66     curstash = defstash = hnew(0);
  67     curstname = str_make("main",4);
  68     stab_xhash(stabent("_main",TRUE)) = defstash;
  69     incstab = aadd(stabent("INC",TRUE));
  70     incstab->str_pok |= SP_MULTI;
  71     for (argc--,argv++; argc; argc--,argv++) {
  72         if (argv[0][0] != '-' || !argv[0][1])
  73             break;
  74 #ifdef DOSUID
  75     if (*validarg)
  76         validarg = " PHOOEY ";
  77     else
  78         validarg = argv[0];
  79 #endif
  80         s = argv[0]+1;
  81       reswitch:
  82         switch (*s) {
  83         case 'a':
  84             minus_a = TRUE;
  85             s++;
  86             goto reswitch;
  87         case 'd':
  88 #ifdef TAINT
  89             if (euid != uid || egid != gid)
  90                 fatal("No -d allowed in setuid scripts");
  91 #endif
  92             perldb = TRUE;
  93             s++;
  94             goto reswitch;
  95 #ifdef DEBUGGING
  96         case 'D':
  97 #ifdef TAINT
  98             if (euid != uid || egid != gid)
  99                 fatal("No -D allowed in setuid scripts");
 100 #endif
 101             debug = atoi(s+1);
 102 #ifdef YYDEBUG
 103             yydebug = (debug & 1);
 104 #endif
 105             break;
 106 #endif
 107         case 'e':
 108 #ifdef TAINT
 109             if (euid != uid || egid != gid)
 110                 fatal("No -e allowed in setuid scripts");
 111 #endif
 112             if (!e_fp) {
 113                 e_tmpname = savestr(TMPPATH);
 114                 (void)mktemp(e_tmpname);
 115                 e_fp = fopen(e_tmpname,"w");
 116             }
 117             if (argv[1])
 118                 fputs(argv[1],e_fp);
 119             (void)putc('\n', e_fp);
 120             argc--,argv++;
 121             break;
 122         case 'i':
 123             inplace = savestr(s+1);
 124             argvoutstab = stabent("ARGVOUT",TRUE);
 125             break;
 126         case 'I':
 127 #ifdef TAINT
 128             if (euid != uid || egid != gid)
 129                 fatal("No -I allowed in setuid scripts");
 130 #endif
 131             str_cat(str,"-");
 132             str_cat(str,s);
 133             str_cat(str," ");
 134             if (*++s) {
 135                 (void)apush(stab_array(incstab),str_make(s,0));
 136             }
 137             else {
 138                 (void)apush(stab_array(incstab),str_make(argv[1],0));
 139                 str_cat(str,argv[1]);
 140                 argc--,argv++;
 141                 str_cat(str," ");
 142             }
 143             break;
 144         case 'n':
 145             minus_n = TRUE;
 146             s++;
 147             goto reswitch;
 148         case 'p':
 149             minus_p = TRUE;
 150             s++;
 151             goto reswitch;
 152         case 'P':
 153 #ifdef TAINT
 154             if (euid != uid || egid != gid)
 155                 fatal("No -P allowed in setuid scripts");
 156 #endif
 157             preprocess = TRUE;
 158             s++;
 159             goto reswitch;
 160         case 's':
 161 #ifdef TAINT
 162             if (euid != uid || egid != gid)
 163                 fatal("No -s allowed in setuid scripts");
 164 #endif
 165             doswitches = TRUE;
 166             s++;
 167             goto reswitch;
 168         case 'S':
 169             dosearch = TRUE;
 170             s++;
 171             goto reswitch;
 172         case 'u':
 173             do_undump = TRUE;
 174             s++;
 175             goto reswitch;
 176         case 'U':
 177             unsafe = TRUE;
 178             s++;
 179             goto reswitch;
 180         case 'v':
 181             fputs(rcsid,stdout);
 182             fputs("\nCopyright (c) 1989, Larry Wall\n\n\
 183 Perl may be copied only under the terms of the GNU General Public License,\n\
 184 a copy of which can be found with the Perl 3.0 distribution kit.\n",stdout);
 185             exit(0);
 186         case 'w':
 187             dowarn = TRUE;
 188             s++;
 189             goto reswitch;
 190         case '-':
 191             argc--,argv++;
 192             goto switch_end;
 193         case 0:
 194             break;
 195         default:
 196             fatal("Unrecognized switch: -%s",s);
 197         }
 198     }
 199   switch_end:
 200     if (e_fp) {
 201         (void)fclose(e_fp);
 202         argc++,argv--;
 203         argv[0] = e_tmpname;
 204     }
 205 #ifndef PRIVLIB
 206 #define PRIVLIB "/usr/local/lib/perl"
 207 #endif
 208     (void)apush(stab_array(incstab),str_make(PRIVLIB,0));
 209
 210     str_set(&str_no,No);
 211     str_set(&str_yes,Yes);
 212
 213     /* open script */
 214
 215     if (argv[0] == Nullch)
 216         argv[0] = "-";
 217     if (dosearch && !index(argv[0], '/') && (s = getenv("PATH"))) {
 218         char *xfound = Nullch, *xfailed = Nullch;
 219         int len;
 220
 221         bufend = s + strlen(s);
 222         while (*s) {
 223             s = cpytill(tokenbuf,s,bufend,':',&len);
 224             if (*s)
 225                 s++;
 226             if (len)
 227                 (void)strcat(tokenbuf+len,"/");
 228             (void)strcat(tokenbuf+len,argv[0]);
 229 #ifdef DEBUGGING
 230             if (debug & 1)
 231                 fprintf(stderr,"Looking for %s\n",tokenbuf);
 232 #endif
 233             if (stat(tokenbuf,&statbuf) < 0)            /* not there? */
 234                 continue;
 235             if ((statbuf.st_mode & S_IFMT) == S_IFREG
 236              && cando(S_IREAD,TRUE,&statbuf) && cando(S_IEXEC,TRUE,&statbuf)) {
 237                 xfound = tokenbuf;              /* bingo! */
 238                 break;
 239             }
 240             if (!xfailed)
 241                 xfailed = savestr(tokenbuf);
 242         }
 243         if (!xfound)
 244             fatal("Can't execute %s", xfailed ? xfailed : argv[0] );
 245         if (xfailed)
 246             Safefree(xfailed);
 247         argv[0] = savestr(xfound);
 248     }
 249
 250     pidstatary = anew(Nullstab);        /* for remembering popen pids, status */
 251
 252     filename = savestr(argv[0]);
 253     origfilename = savestr(filename);
 254     if (strEQ(filename,"-"))
 255         argv[0] = "";
 256     if (preprocess) {
 257         str_cat(str,"-I");
 258         str_cat(str,PRIVLIB);
 259         (void)sprintf(buf, "\
 260 /bin/sed -e '/^[^#]/b' \
 261  -e '/^#[       ]*include[      ]/b' \
 262  -e '/^#[       ]*define[       ]/b' \
 263  -e '/^#[       ]*if[   ]/b' \
 264  -e '/^#[       ]*ifdef[        ]/b' \
 265  -e '/^#[       ]*ifndef[       ]/b' \
 266  -e '/^#[       ]*else/b' \
 267  -e '/^#[       ]*endif/b' \
 268  -e 's/^#.*//' \
 269  %s | %s -C %s %s",
 270           argv[0], CPPSTDIN, str_get(str), CPPMINUS);
 271 #ifdef IAMSUID                          /* actually, this is caught earlier */
 272         if (euid != uid && !euid)       /* if running suidperl */
 273 #ifdef SETEUID
 274             (void)seteuid(uid);         /* musn't stay setuid root */
 275 #else
 276 #ifdef SETREUID
 277             (void)setreuid(-1, uid);
 278 #else
 279             setuid(uid);
 280 #endif
 281 #endif
 282 #endif /* IAMSUID */
 283         rsfp = mypopen(buf,"r");
 284     }
 285     else if (!*argv[0])
 286         rsfp = stdin;
 287     else
 288         rsfp = fopen(argv[0],"r");
 289     if (rsfp == Nullfp) {
 290         extern char *sys_errlist[];
 291         extern int errno;
 292
 293 #ifdef DOSUID
 294 #ifndef IAMSUID         /* in case script is not readable before setuid */
 295         if (euid && stat(filename,&statbuf) >= 0 &&
 296           statbuf.st_mode & (S_ISUID|S_ISGID)) {
 297             (void)sprintf(buf, "%s/%s", BIN, "suidperl");
 298             execv(buf, origargv);       /* try again */
 299             fatal("Can't do setuid\n");
 300         }
 301 #endif
 302 #endif
 303         fatal("Can't open perl script \"%s\": %s\n",
 304           filename, sys_errlist[errno]);
 305     }
 306     str_free(str);              /* free -I directories */
 307
 308     /* do we need to emulate setuid on scripts? */
 309
 310     /* This code is for those BSD systems that have setuid #! scripts disabled
 311      * in the kernel because of a security problem.  Merely defining DOSUID
 312      * in perl will not fix that problem, but if you have disabled setuid
 313      * scripts in the kernel, this will attempt to emulate setuid and setgid
 314      * on scripts that have those now-otherwise-useless bits set.  The setuid
 315      * root version must be called suidperl.  If regular perl discovers that
 316      * it has opened a setuid script, it calls suidperl with the same argv
 317      * that it had.  If suidperl finds that the script it has just opened
 318      * is NOT setuid root, it sets the effective uid back to the uid.  We
 319      * don't just make perl setuid root because that loses the effective
 320      * uid we had before invoking perl, if it was different from the uid.
 321      *
 322      * DOSUID must be defined in both perl and suidperl, and IAMSUID must
 323      * be defined in suidperl only.  suidperl must be setuid root.  The
 324      * Configure script will set this up for you if you want it.
 325      *
 326      * There is also the possibility of have a script which is running
 327      * set-id due to a C wrapper.  We want to do the TAINT checks
 328      * on these set-id scripts, but don't want to have the overhead of
 329      * them in normal perl, and can't use suidperl because it will lose
 330      * the effective uid info, so we have an additional non-setuid root
 331      * version called taintperl that just does the TAINT checks.
 332      */
 333
 334 #ifdef DOSUID
 335     if (fstat(fileno(rsfp),&statbuf) < 0)       /* normal stat is insecure */
 336         fatal("Can't stat script \"%s\"",filename);
 337     if (statbuf.st_mode & (S_ISUID|S_ISGID)) {
 338         int len;
 339
 340 #ifdef IAMSUID
 341 #ifndef SETREUID
 342         /* On this access check to make sure the directories are readable,
 343          * there is actually a small window that the user could use to make
 344          * filename point to an accessible directory.  So there is a faint
 345          * chance that someone could execute a setuid script down in a
 346          * non-accessible directory.  I don't know what to do about that.
 347          * But I don't think it's too important.  The manual lies when
 348          * it says access() is useful in setuid programs.
 349          */
 350         if (access(filename,1))         /* as a double check */
 351             fatal("Permission denied");
 352 #else
 353         /* If we can swap euid and uid, then we can determine access rights
 354          * with a simple stat of the file, and then compare device and
 355          * inode to make sure we did stat() on the same file we opened.
 356          * Then we just have to make sure he or she can execute it.
 357          */
 358         {
 359             struct stat tmpstatbuf;
 360
 361             if (setreuid(euid,uid) < 0 || getuid() != euid || geteuid() != uid)
 362                 fatal("Can't swap uid and euid");       /* really paranoid */
 363             if (stat(filename,&tmpstatbuf) < 0) /* testing full pathname here */
 364                 fatal("Permission denied");
 365             if (tmpstatbuf.st_dev != statbuf.st_dev ||
 366                 tmpstatbuf.st_ino != statbuf.st_ino) {
 367                 (void)fclose(rsfp);
 368                 if (rsfp = mypopen("/bin/mail root","w")) {     /* heh, heh */
 369                     fprintf(rsfp,
 370 "User %d tried to run dev %d ino %d in place of dev %d ino %d!\n\
 371 (Filename of set-id script was %s, uid %d gid %d.)\n\nSincerely,\nperl\n",
 372                         uid,tmpstatbuf.st_dev, tmpstatbuf.st_ino,
 373                         statbuf.st_dev, statbuf.st_ino,
 374                         filename, statbuf.st_uid, statbuf.st_gid);
 375                     (void)mypclose(rsfp);
 376                 }
 377                 fatal("Permission denied\n");
 378             }
 379             if (setreuid(uid,euid) < 0 || getuid() != uid || geteuid() != euid)
 380                 fatal("Can't reswap uid and euid");
 381             if (!cando(S_IEXEC,FALSE,&statbuf))         /* can real uid exec? */
 382                 fatal("Permission denied\n");
 383         }
 384 #endif /* SETREUID */
 385 #endif /* IAMSUID */
 386
 387         if ((statbuf.st_mode & S_IFMT) != S_IFREG)
 388             fatal("Permission denied");
 389         if ((statbuf.st_mode >> 6) & S_IWRITE)
 390             fatal("Setuid/gid script is writable by world");
 391         doswitches = FALSE;             /* -s is insecure in suid */
 392         line++;
 393         if (fgets(tokenbuf,sizeof tokenbuf, rsfp) == Nullch ||
 394           strnNE(tokenbuf,"#!",2) )     /* required even on Sys V */
 395             fatal("No #! line");
 396         for (s = tokenbuf+2; !isspace(*s); s++) ;
 397         if (strnNE(s-4,"perl",4))       /* sanity check */
 398             fatal("Not a perl script");
 399         while (*s == ' ' || *s == '\t') s++;
 400         /*
 401          * #! arg must be what we saw above.  They can invoke it by
 402          * mentioning suidperl explicitly, but they may not add any strange
 403          * arguments beyond what #! says if they do invoke suidperl that way.
 404          */
 405         len = strlen(validarg);
 406         if (strEQ(validarg," PHOOEY ") ||
 407             strnNE(s,validarg,len) || !isspace(s[len]))
 408             fatal("Args must match #! line");
 409
 410 #ifndef IAMSUID
 411         if (euid != uid && (statbuf.st_mode & S_ISUID) &&
 412             euid == statbuf.st_uid)
 413             if (!do_undump)
 414                 fatal("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
 415 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
 416 #endif /* IAMSUID */
 417
 418         if (euid) {     /* oops, we're not the setuid root perl */
 419             (void)fclose(rsfp);
 420 #ifndef IAMSUID
 421             (void)sprintf(buf, "%s/%s", BIN, "suidperl");
 422             execv(buf, origargv);       /* try again */
 423 #endif
 424             fatal("Can't do setuid\n");
 425         }
 426
 427         if (statbuf.st_mode & S_ISGID && statbuf.st_gid != getegid())
 428 #ifdef SETEGID
 429             (void)setegid(statbuf.st_gid);
 430 #else
 431 #ifdef SETREGID
 432             (void)setregid((GIDTYPE)-1,statbuf.st_gid);
 433 #else
 434             setgid(statbuf.st_gid);
 435 #endif
 436 #endif
 437         if (statbuf.st_mode & S_ISUID) {
 438             if (statbuf.st_uid != euid)
 439 #ifdef SETEUID
 440                 (void)seteuid(statbuf.st_uid);  /* all that for this */
 441 #else
 442 #ifdef SETREUID
 443                 (void)setreuid((UIDTYPE)-1,statbuf.st_uid);
 444 #else
 445                 setuid(statbuf.st_uid);
 446 #endif
 447 #endif
 448         }
 449         else if (uid)                   /* oops, mustn't run as root */
 450 #ifdef SETEUID
 451             (void)seteuid((UIDTYPE)uid);
 452 #else
 453 #ifdef SETREUID
 454             (void)setreuid((UIDTYPE)-1,(UIDTYPE)uid);
 455 #else
 456             setuid((UIDTYPE)uid);
 457 #endif
 458 #endif
 459         euid = (int)geteuid();
 460         if (!cando(S_IEXEC,TRUE,&statbuf))
 461             fatal("Permission denied\n");       /* they can't do this */
 462     }
 463 #ifdef IAMSUID
 464     else if (preprocess)
 465         fatal("-P not allowed for setuid/setgid script\n");
 466     else
 467         fatal("Script is not setuid/setgid in suidperl\n");
 468 #else
 469 #ifndef TAINT           /* we aren't taintperl or suidperl */
 470     /* script has a wrapper--can't run suidperl or we lose euid */
 471     else if (euid != uid || egid != gid) {
 472         (void)fclose(rsfp);
 473         (void)sprintf(buf, "%s/%s", BIN, "taintperl");
 474         execv(buf, origargv);   /* try again */
 475         fatal("Can't run setuid script with taint checks");
 476     }
 477 #endif /* TAINT */
 478 #endif /* IAMSUID */
 479 #else /* !DOSUID */
 480 #ifndef TAINT           /* we aren't taintperl or suidperl */
 481     if (euid != uid || egid != gid) {   /* (suidperl doesn't exist, in fact) */
 482 #ifndef SETUID_SCRIPTS_ARE_SECURE_NOW
 483         fstat(fileno(rsfp),&statbuf);   /* may be either wrapped or real suid */
 484         if ((euid != uid && euid == statbuf.st_uid && statbuf.st_mode & S_ISUID)
 485             ||
 486             (egid != gid && egid == statbuf.st_gid && statbuf.st_mode & S_ISGID)
 487            )
 488             if (!do_undump)
 489                 fatal("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
 490 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
 491 #endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
 492         /* not set-id, must be wrapped */
 493         (void)fclose(rsfp);
 494         (void)sprintf(buf, "%s/%s", BIN, "taintperl");
 495         execv(buf, origargv);   /* try again */
 496         fatal("Can't run setuid script with taint checks");
 497     }
 498 #endif /* TAINT */
 499 #endif /* DOSUID */
 500
 501     defstab = stabent("_",TRUE);
 502
 503     if (perldb) {
 504         debstash = hnew(0);
 505         stab_xhash(stabent("_DB",TRUE)) = debstash;
 506         curstash = debstash;
 507         lineary = stab_xarray(aadd((tmpstab = stabent("line",TRUE))));
 508         tmpstab->str_pok |= SP_MULTI;
 509         subname = str_make("main",4);
 510         DBstab = stabent("DB",TRUE);
 511         DBstab->str_pok |= SP_MULTI;
 512         DBsub = hadd(tmpstab = stabent("sub",TRUE));
 513         tmpstab->str_pok |= SP_MULTI;
 514         DBsingle = stab_val((tmpstab = stabent("single",TRUE)));
 515         tmpstab->str_pok |= SP_MULTI;
 516         curstash = defstash;
 517     }
 518
 519     /* init tokener */
 520
 521     bufend = bufptr = str_get(linestr);
 522
 523     savestack = anew(Nullstab);         /* for saving non-local values */
 524     stack = anew(Nullstab);             /* for saving non-local values */
 525     stack->ary_flags = 0;               /* not a real array */
 526
 527     /* now parse the script */
 528
 529     error_count = 0;
 530     if (yyparse() || error_count)
 531         fatal("Execution aborted due to compilation errors.\n");
 532
 533     New(50,loop_stack,128,struct loop);
 534     New(51,debname,128,char);
 535     New(52,debdelim,128,char);
 536     curstash = defstash;
 537
 538     preprocess = FALSE;
 539     if (e_fp) {
 540         e_fp = Nullfp;
 541         (void)UNLINK(e_tmpname);
 542     }
 543
 544     /* initialize everything that won't change if we undump */
 545
 546     if (sigstab = stabent("SIG",allstabs)) {
 547         sigstab->str_pok |= SP_MULTI;
 548         (void)hadd(sigstab);
 549     }
 550
 551     magicalize("!#?^~=-%0123456789.+&*()<>,\\/[|`':");
 552
 553     amperstab = stabent("&",allstabs);
 554     leftstab = stabent("`",allstabs);
 555     rightstab = stabent("'",allstabs);
 556     sawampersand = (amperstab || leftstab || rightstab);
 557     if (tmpstab = stabent(":",allstabs))
 558         str_set(STAB_STR(tmpstab),chopset);
 559
 560     /* these aren't necessarily magical */
 561     if (tmpstab = stabent(";",allstabs))
 562         str_set(STAB_STR(tmpstab),"\034");
 563 #ifdef TAINT
 564     tainted = 1;
 565 #endif
 566     if (tmpstab = stabent("0",allstabs))
 567         str_set(STAB_STR(tmpstab),origfilename);
 568 #ifdef TAINT
 569     tainted = 0;
 570 #endif
 571     if (tmpstab = stabent("]",allstabs))
 572         str_set(STAB_STR(tmpstab),rcsid);
 573     str_nset(stab_val(stabent("\"", TRUE)), " ", 1);
 574
 575     stdinstab = stabent("STDIN",TRUE);
 576     stdinstab->str_pok |= SP_MULTI;
 577     stab_io(stdinstab) = stio_new();
 578     stab_io(stdinstab)->ifp = stdin;
 579     tmpstab = stabent("stdin",TRUE);
 580     stab_io(tmpstab) = stab_io(stdinstab);
 581     tmpstab->str_pok |= SP_MULTI;
 582
 583     tmpstab = stabent("STDOUT",TRUE);
 584     tmpstab->str_pok |= SP_MULTI;
 585     stab_io(tmpstab) = stio_new();
 586     stab_io(tmpstab)->ofp = stab_io(tmpstab)->ifp = stdout;
 587     defoutstab = tmpstab;
 588     tmpstab = stabent("stdout",TRUE);
 589     stab_io(tmpstab) = stab_io(defoutstab);
 590     tmpstab->str_pok |= SP_MULTI;
 591
 592     curoutstab = stabent("STDERR",TRUE);
 593     curoutstab->str_pok |= SP_MULTI;
 594     stab_io(curoutstab) = stio_new();
 595     stab_io(curoutstab)->ofp = stab_io(curoutstab)->ifp = stderr;
 596     tmpstab = stabent("stderr",TRUE);
 597     stab_io(tmpstab) = stab_io(curoutstab);
 598     tmpstab->str_pok |= SP_MULTI;
 599     curoutstab = defoutstab;            /* switch back to STDOUT */
 600
 601     statname = Str_new(66,0);           /* last filename we did stat on */
 602
 603     perldb = FALSE;             /* don't try to instrument evals */
 604
 605     if (dowarn) {
 606         stab_check('A','Z');
 607         stab_check('a','z');
 608     }
 609
 610     if (do_undump)
 611         abort();
 612
 613   just_doit:            /* come here if running an undumped a.out */
 614     argc--,argv++;      /* skip name of script */
 615     if (doswitches) {
 616         for (; argc > 0 && **argv == '-'; argc--,argv++) {
 617             if (argv[0][1] == '-') {
 618                 argc--,argv++;
 619                 break;
 620             }
 621             str_numset(stab_val(stabent(argv[0]+1,TRUE)),(double)1.0);
 622         }
 623     }
 624 #ifdef TAINT
 625     tainted = 1;
 626 #endif
 627     if (argvstab = stabent("ARGV",allstabs)) {
 628         argvstab->str_pok |= SP_MULTI;
 629         (void)aadd(argvstab);
 630         for (; argc > 0; argc--,argv++) {
 631             (void)apush(stab_array(argvstab),str_make(argv[0],0));
 632         }
 633     }
 634 #ifdef TAINT
 635     (void) stabent("ENV",TRUE);         /* must test PATH and IFS */
 636 #endif
 637     if (envstab = stabent("ENV",allstabs)) {
 638         envstab->str_pok |= SP_MULTI;
 639         (void)hadd(envstab);
 640         for (; *env; env++) {
 641             if (!(s = index(*env,'=')))
 642                 continue;
 643             *s++ = '\0';
 644             str = str_make(s--,0);
 645             str_magic(str, envstab, 'E', *env, s - *env);
 646             (void)hstore(stab_hash(envstab), *env, s - *env, str, 0);
 647             *s = '=';
 648         }
 649     }
 650 #ifdef TAINT
 651     tainted = 0;
 652 #endif
 653     if (tmpstab = stabent("$",allstabs))
 654         str_numset(STAB_STR(tmpstab),(double)getpid());
 655
 656     if (setjmp(top_env))        /* sets goto_targ on longjump */
 657         loop_ptr = 0;           /* start label stack again */
 658
 659 #ifdef DEBUGGING
 660     if (debug & 1024)
 661         dump_all();
 662     if (debug)
 663         fprintf(stderr,"\nEXECUTING...\n\n");
 664 #endif
 665
 666     /* do it */
 667
 668     (void) cmd_exec(main_root,G_SCALAR,-1);
 669
 670     if (goto_targ)
 671         fatal("Can't find label \"%s\"--aborting",goto_targ);
 672     exit(0);
 673     /* NOTREACHED */
 674 }
 675
 676 magicalize(list)
 677 register char *list;
 678 {
 679     register STAB *stab;
 680     char sym[2];
 681
 682     sym[1] = '\0';
 683     while (*sym = *list++) {
 684         if (stab = stabent(sym,allstabs)) {
 685             stab_flags(stab) = SF_VMAGIC;
 686             str_magic(stab_val(stab), stab, 0, Nullch, 0);
 687         }
 688     }
 689 }
 690
 691 /* this routine is in perly.c by virtue of being sort of an alternate main() */
 692
 693 int
 694 do_eval(str,optype,stash,gimme,arglast)
 695 STR *str;
 696 int optype;
 697 HASH *stash;
 698 int gimme;
 699 int *arglast;
 700 {
 701     STR **st = stack->ary_array;
 702     int retval;
 703     CMD *myroot;
 704     ARRAY *ar;
 705     int i;
 706     char *oldfile = filename;
 707     line_t oldline = line;
 708     int oldtmps_base = tmps_base;
 709     int oldsave = savestack->ary_fill;
 710     SPAT *oldspat = curspat;
 711     static char *last_eval = Nullch;
 712     static CMD *last_root = Nullcmd;
 713     int sp = arglast[0];
 714
 715     tmps_base = tmps_max;
 716     if (curstash != stash) {
 717         (void)savehptr(&curstash);
 718         curstash = stash;
 719     }
 720     str_set(stab_val(stabent("@",TRUE)),"");
 721     if (optype != O_DOFILE) {   /* normal eval */
 722         filename = "(eval)";
 723         line = 1;
 724         str_sset(linestr,str);
 725         str_cat(linestr,";");           /* be kind to them */
 726     }
 727     else {
 728         if (last_root) {
 729             Safefree(last_eval);
 730             cmd_free(last_root);
 731             last_root = Nullcmd;
 732         }
 733         filename = savestr(str_get(str));       /* can't free this easily */
 734         str_set(linestr,"");
 735         rsfp = fopen(filename,"r");
 736         ar = stab_array(incstab);
 737         if (!rsfp && *filename != '/') {
 738             for (i = 0; i <= ar->ary_fill; i++) {
 739                 (void)sprintf(buf,"%s/%s",str_get(afetch(ar,i,TRUE)),filename);
 740                 rsfp = fopen(buf,"r");
 741                 if (rsfp) {
 742                     filename = savestr(buf);
 743                     break;
 744                 }
 745             }
 746         }
 747         if (!rsfp) {
 748             filename = oldfile;
 749             tmps_base = oldtmps_base;
 750             if (gimme != G_ARRAY)
 751                 st[++sp] = &str_undef;
 752             return sp;
 753         }
 754         line = 0;
 755     }
 756     in_eval++;
 757     oldoldbufptr = oldbufptr = bufptr = str_get(linestr);
 758     bufend = bufptr + linestr->str_cur;
 759     if (setjmp(eval_env)) {
 760         retval = 1;
 761         last_root = Nullcmd;
 762     }
 763     else {
 764         error_count = 0;
 765         if (rsfp)
 766             retval = yyparse();
 767         else if (last_root && *bufptr == *last_eval && strEQ(bufptr,last_eval)){
 768             retval = 0;
 769             eval_root = last_root;      /* no point in reparsing */
 770         }
 771         else if (in_eval == 1) {
 772             if (last_root) {
 773                 Safefree(last_eval);
 774                 cmd_free(last_root);
 775             }
 776             last_eval = savestr(bufptr);
 777             last_root = Nullcmd;
 778             retval = yyparse();
 779             if (!retval)
 780                 last_root = eval_root;
 781         }
 782         else
 783             retval = yyparse();
 784     }
 785     myroot = eval_root;         /* in case cmd_exec does another eval! */
 786     if (retval || error_count) {
 787         str = &str_undef;
 788         last_root = Nullcmd;    /* can't free on error, for some reason */
 789         if (rsfp) {
 790             fclose(rsfp);
 791             rsfp = 0;
 792         }
 793     }
 794     else {
 795         sp = cmd_exec(eval_root,gimme,sp);
 796         st = stack->ary_array;
 797         for (i = arglast[0] + 1; i <= sp; i++)
 798             st[i] = str_static(st[i]);
 799                                 /* if we don't save result, free zaps it */
 800         if (in_eval != 1 && myroot != last_root)
 801             cmd_free(myroot);
 802     }
 803     in_eval--;
 804     filename = oldfile;
 805     line = oldline;
 806     tmps_base = oldtmps_base;
 807     curspat = oldspat;
 808     if (savestack->ary_fill > oldsave)  /* let them use local() */
 809         restorelist(oldsave);
 810     return sp;
 811 }