perly.c

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