perly.c

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