perly.c

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