perly.c

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