perly.c

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