perly.c

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