perl.c

   1 char rcsid[] = "$RCSfile: perl.c,v $$Revision: 4.0.1.4 $$Date: 91/06/10 01:23:07 $\nPatch level: ###\n";
   2 /*
   3  *    Copyright (c) 1991, Larry Wall
   4  *
   5  *    You may distribute under the terms of either the GNU General Public
   6  *    License or the Artistic License, as specified in the README file.
   7  *
   8  * $Log:        perl.c,v $
   9  * Revision 4.0.1.4  91/06/10  01:23:07  lwall
  10  * patch10: perl -v printed incorrect copyright notice
  11  *
  12  * Revision 4.0.1.3  91/06/07  11:40:18  lwall
  13  * patch4: changed old $^P to $^X
  14  *
  15  * Revision 4.0.1.2  91/06/07  11:26:16  lwall
  16  * patch4: new copyright notice
  17  * patch4: added $^P variable to control calling of perldb routines
  18  * patch4: added $^F variable to specify maximum system fd, default 2
  19  * patch4: debugger lost track of lines in eval
  20  *
  21  * Revision 4.0.1.1  91/04/11  17:49:05  lwall
  22  * patch1: fixed undefined environ problem
  23  *
  24  * Revision 4.0  91/03/20  01:37:44  lwall
  25  * 4.0 baseline.
  26  *
  27  */
  28
  29 #include "EXTERN.h"
  30 #include "perl.h"
  31 #include "perly.h"
  32 #ifdef MSDOS
  33 #include "patchlev.h"
  34 #else
  35 #include "patchlevel.h"
  36 #endif
  37
  38 char *getenv();
  39
  40 #ifdef IAMSUID
  41 #ifndef DOSUID
  42 #define DOSUID
  43 #endif
  44 #endif
  45
  46 #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
  47 #ifdef DOSUID
  48 #undef DOSUID
  49 #endif
  50 #endif
  51
  52 static char* moreswitches();
  53 static char* cddir;
  54 static bool minus_c;
  55 static char patchlevel[6];
  56 static char *nrs = "\n";
  57 static int nrschar = '\n';      /* final char of rs, or 0777 if none */
  58 static int nrslen = 1;
  59
  60 main(argc,argv,env)
  61 register int argc;
  62 register char **argv;
  63 register char **env;
  64 {
  65     register STR *str;
  66     register char *s;
  67     char *getenv();
  68     bool dosearch = FALSE;
  69 #ifdef DOSUID
  70     char *validarg = "";
  71 #endif
  72
  73 #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
  74 #ifdef IAMSUID
  75 #undef IAMSUID
  76     fatal("suidperl is no longer needed since the kernel can now execute\n\
  77 setuid perl scripts securely.\n");
  78 #endif
  79 #endif
  80
  81     origargv = argv;
  82     origargc = argc;
  83     origenviron = environ;
  84     uid = (int)getuid();
  85     euid = (int)geteuid();
  86     gid = (int)getgid();
  87     egid = (int)getegid();
  88     sprintf(patchlevel,"%3.3s%2.2d", index(rcsid,'4'), PATCHLEVEL);
  89 #ifdef MSDOS
  90     /*
  91      * There is no way we can refer to them from Perl so close them to save
  92      * space.  The other alternative would be to provide STDAUX and STDPRN
  93      * filehandles.
  94      */
  95     (void)fclose(stdaux);
  96     (void)fclose(stdprn);
  97 #endif
  98     if (do_undump) {
  99         origfilename = savestr(argv[0]);
 100         do_undump = 0;
 101         loop_ptr = -1;          /* start label stack again */
 102         goto just_doit;
 103     }
 104     (void)sprintf(index(rcsid,'#'), "%d\n", PATCHLEVEL);
 105     linestr = Str_new(65,80);
 106     str_nset(linestr,"",0);
 107     str = str_make("",0);               /* first used for -I flags */
 108     curstash = defstash = hnew(0);
 109     curstname = str_make("main",4);
 110     stab_xhash(stabent("_main",TRUE)) = defstash;
 111     defstash->tbl_name = "main";
 112     incstab = hadd(aadd(stabent("INC",TRUE)));
 113     incstab->str_pok |= SP_MULTI;
 114     for (argc--,argv++; argc > 0; argc--,argv++) {
 115         if (argv[0][0] != '-' || !argv[0][1])
 116             break;
 117 #ifdef DOSUID
 118     if (*validarg)
 119         validarg = " PHOOEY ";
 120     else
 121         validarg = argv[0];
 122 #endif
 123         s = argv[0]+1;
 124       reswitch:
 125         switch (*s) {
 126         case '0':
 127         case 'a':
 128         case 'c':
 129         case 'd':
 130         case 'D':
 131         case 'i':
 132         case 'l':
 133         case 'n':
 134         case 'p':
 135         case 'u':
 136         case 'U':
 137         case 'v':
 138         case 'w':
 139             if (s = moreswitches(s))
 140                 goto reswitch;
 141             break;
 142
 143         case 'e':
 144 #ifdef TAINT
 145             if (euid != uid || egid != gid)
 146                 fatal("No -e allowed in setuid scripts");
 147 #endif
 148             if (!e_fp) {
 149                 e_tmpname = savestr(TMPPATH);
 150                 (void)mktemp(e_tmpname);
 151                 e_fp = fopen(e_tmpname,"w");
 152                 if (!e_fp)
 153                     fatal("Cannot open temporary file");
 154             }
 155             if (argv[1]) {
 156                 fputs(argv[1],e_fp);
 157                 argc--,argv++;
 158             }
 159             (void)putc('\n', e_fp);
 160             break;
 161         case 'I':
 162 #ifdef TAINT
 163             if (euid != uid || egid != gid)
 164                 fatal("No -I allowed in setuid scripts");
 165 #endif
 166             str_cat(str,"-");
 167             str_cat(str,s);
 168             str_cat(str," ");
 169             if (*++s) {
 170                 (void)apush(stab_array(incstab),str_make(s,0));
 171             }
 172             else if (argv[1]) {
 173                 (void)apush(stab_array(incstab),str_make(argv[1],0));
 174                 str_cat(str,argv[1]);
 175                 argc--,argv++;
 176                 str_cat(str," ");
 177             }
 178             break;
 179         case 'P':
 180 #ifdef TAINT
 181             if (euid != uid || egid != gid)
 182                 fatal("No -P allowed in setuid scripts");
 183 #endif
 184             preprocess = TRUE;
 185             s++;
 186             goto reswitch;
 187         case 's':
 188 #ifdef TAINT
 189             if (euid != uid || egid != gid)
 190                 fatal("No -s allowed in setuid scripts");
 191 #endif
 192             doswitches = TRUE;
 193             s++;
 194             goto reswitch;
 195         case 'S':
 196             dosearch = TRUE;
 197             s++;
 198             goto reswitch;
 199         case 'x':
 200             doextract = TRUE;
 201             s++;
 202             if (*s)
 203                 cddir = savestr(s);
 204             break;
 205         case '-':
 206             argc--,argv++;
 207             goto switch_end;
 208         case 0:
 209             break;
 210         default:
 211             fatal("Unrecognized switch: -%s",s);
 212         }
 213     }
 214   switch_end:
 215     if (e_fp) {
 216         (void)fclose(e_fp);
 217         argc++,argv--;
 218         argv[0] = e_tmpname;
 219     }
 220
 221 #ifdef MSDOS
 222 #define PERLLIB_SEP ';'
 223 #else
 224 #define PERLLIB_SEP ':'
 225 #endif
 226 #ifndef TAINT           /* Can't allow arbitrary PERLLIB in setuid script */
 227     {
 228         char * s2 = getenv("PERLLIB");
 229
 230         if ( s2 ) {
 231             /* Break at all separators */
 232             while ( *s2 ) {
 233                 /* First, skip any consecutive separators */
 234                 while ( *s2 == PERLLIB_SEP ) {
 235                     /* Uncomment the next line for PATH semantics */
 236                     /* (void)apush(stab_array(incstab),str_make(".",1)); */
 237                     s2++;
 238                 }
 239                 if ( (s = index(s2,PERLLIB_SEP)) != Nullch ) {
 240                     (void)apush(stab_array(incstab),str_make(s2,(int)(s-s2)));
 241                     s2 = s+1;
 242                 } else {
 243                     (void)apush(stab_array(incstab),str_make(s2,0));
 244                     break;
 245                 }
 246             }
 247         }
 248     }
 249 #endif /* TAINT */
 250
 251 #ifndef PRIVLIB
 252 #define PRIVLIB "/usr/local/lib/perl"
 253 #endif
 254     (void)apush(stab_array(incstab),str_make(PRIVLIB,0));
 255     (void)apush(stab_array(incstab),str_make(".",1));
 256
 257     str_set(&str_no,No);
 258     str_set(&str_yes,Yes);
 259
 260     /* open script */
 261
 262     if (argv[0] == Nullch)
 263 #ifdef MSDOS
 264     {
 265         if ( isatty(fileno(stdin)) )
 266           moreswitches("v");
 267         argv[0] = "-";
 268     }
 269 #else
 270         argv[0] = "-";
 271 #endif
 272     if (dosearch && !index(argv[0], '/') && (s = getenv("PATH"))) {
 273         char *xfound = Nullch, *xfailed = Nullch;
 274         int len;
 275
 276         bufend = s + strlen(s);
 277         while (*s) {
 278 #ifndef MSDOS
 279             s = cpytill(tokenbuf,s,bufend,':',&len);
 280 #else
 281             for (len = 0; *s && *s != ';'; tokenbuf[len++] = *s++);
 282             tokenbuf[len] = '\0';
 283 #endif
 284             if (*s)
 285                 s++;
 286 #ifndef MSDOS
 287             if (len && tokenbuf[len-1] != '/')
 288 #else
 289             if (len && tokenbuf[len-1] != '\\')
 290 #endif
 291                 (void)strcat(tokenbuf+len,"/");
 292             (void)strcat(tokenbuf+len,argv[0]);
 293 #ifdef DEBUGGING
 294             if (debug & 1)
 295                 fprintf(stderr,"Looking for %s\n",tokenbuf);
 296 #endif
 297             if (stat(tokenbuf,&statbuf) < 0)            /* not there? */
 298                 continue;
 299             if (S_ISREG(statbuf.st_mode)
 300              && cando(S_IRUSR,TRUE,&statbuf) && cando(S_IXUSR,TRUE,&statbuf)) {
 301                 xfound = tokenbuf;              /* bingo! */
 302                 break;
 303             }
 304             if (!xfailed)
 305                 xfailed = savestr(tokenbuf);
 306         }
 307         if (!xfound)
 308             fatal("Can't execute %s", xfailed ? xfailed : argv[0] );
 309         if (xfailed)
 310             Safefree(xfailed);
 311         argv[0] = savestr(xfound);
 312     }
 313
 314     fdpid = anew(Nullstab);     /* for remembering popen pids by fd */
 315     pidstatus = hnew(COEFFSIZE);/* for remembering status of dead pids */
 316
 317     origfilename = savestr(argv[0]);
 318     curcmd->c_filestab = fstab(origfilename);
 319     if (strEQ(origfilename,"-"))
 320         argv[0] = "";
 321     if (preprocess) {
 322         str_cat(str,"-I");
 323         str_cat(str,PRIVLIB);
 324         (void)sprintf(buf, "\
 325 %ssed %s -e '/^[^#]/b' \
 326  -e '/^#[       ]*include[      ]/b' \
 327  -e '/^#[       ]*define[       ]/b' \
 328  -e '/^#[       ]*if[   ]/b' \
 329  -e '/^#[       ]*ifdef[        ]/b' \
 330  -e '/^#[       ]*ifndef[       ]/b' \
 331  -e '/^#[       ]*else/b' \
 332  -e '/^#[       ]*endif/b' \
 333  -e 's/^#.*//' \
 334  %s | %s -C %s %s",
 335 #ifdef MSDOS
 336           "",
 337 #else
 338           "/bin/",
 339 #endif
 340           (doextract ? "-e '1,/^#/d\n'" : ""),
 341           argv[0], CPPSTDIN, str_get(str), CPPMINUS);
 342 #ifdef DEBUGGING
 343         if (debug & 64) {
 344             fputs(buf,stderr);
 345             fputs("\n",stderr);
 346         }
 347 #endif
 348         doextract = FALSE;
 349 #ifdef IAMSUID                          /* actually, this is caught earlier */
 350         if (euid != uid && !euid)       /* if running suidperl */
 351 #ifdef HAS_SETEUID
 352             (void)seteuid(uid);         /* musn't stay setuid root */
 353 #else
 354 #ifdef HAS_SETREUID
 355             (void)setreuid(-1, uid);
 356 #else
 357             setuid(uid);
 358 #endif
 359 #endif
 360 #endif /* IAMSUID */
 361         rsfp = mypopen(buf,"r");
 362     }
 363     else if (!*argv[0])
 364         rsfp = stdin;
 365     else
 366         rsfp = fopen(argv[0],"r");
 367     if (rsfp == Nullfp) {
 368 #ifdef DOSUID
 369 #ifndef IAMSUID         /* in case script is not readable before setuid */
 370         if (euid && stat(stab_val(curcmd->c_filestab)->str_ptr,&statbuf) >= 0 &&
 371           statbuf.st_mode & (S_ISUID|S_ISGID)) {
 372             (void)sprintf(buf, "%s/sperl%s", BIN, patchlevel);
 373             execv(buf, origargv);       /* try again */
 374             fatal("Can't do setuid\n");
 375         }
 376 #endif
 377 #endif
 378         fatal("Can't open perl script \"%s\": %s\n",
 379           stab_val(curcmd->c_filestab)->str_ptr, strerror(errno));
 380     }
 381     str_free(str);              /* free -I directories */
 382     str = Nullstr;
 383
 384     /* do we need to emulate setuid on scripts? */
 385
 386     /* This code is for those BSD systems that have setuid #! scripts disabled
 387      * in the kernel because of a security problem.  Merely defining DOSUID
 388      * in perl will not fix that problem, but if you have disabled setuid
 389      * scripts in the kernel, this will attempt to emulate setuid and setgid
 390      * on scripts that have those now-otherwise-useless bits set.  The setuid
 391      * root version must be called suidperl or sperlN.NNN.  If regular perl
 392      * discovers that it has opened a setuid script, it calls suidperl with
 393      * the same argv that it had.  If suidperl finds that the script it has
 394      * just opened is NOT setuid root, it sets the effective uid back to the
 395      * uid.  We don't just make perl setuid root because that loses the
 396      * effective uid we had before invoking perl, if it was different from the
 397      * uid.
 398      *
 399      * DOSUID must be defined in both perl and suidperl, and IAMSUID must
 400      * be defined in suidperl only.  suidperl must be setuid root.  The
 401      * Configure script will set this up for you if you want it.
 402      *
 403      * There is also the possibility of have a script which is running
 404      * set-id due to a C wrapper.  We want to do the TAINT checks
 405      * on these set-id scripts, but don't want to have the overhead of
 406      * them in normal perl, and can't use suidperl because it will lose
 407      * the effective uid info, so we have an additional non-setuid root
 408      * version called taintperl or tperlN.NNN that just does the TAINT checks.
 409      */
 410
 411 #ifdef DOSUID
 412     if (fstat(fileno(rsfp),&statbuf) < 0)       /* normal stat is insecure */
 413         fatal("Can't stat script \"%s\"",origfilename);
 414     if (statbuf.st_mode & (S_ISUID|S_ISGID)) {
 415         int len;
 416
 417 #ifdef IAMSUID
 418 #ifndef HAS_SETREUID
 419         /* On this access check to make sure the directories are readable,
 420          * there is actually a small window that the user could use to make
 421          * filename point to an accessible directory.  So there is a faint
 422          * chance that someone could execute a setuid script down in a
 423          * non-accessible directory.  I don't know what to do about that.
 424          * But I don't think it's too important.  The manual lies when
 425          * it says access() is useful in setuid programs.
 426          */
 427         if (access(stab_val(curcmd->c_filestab)->str_ptr,1))    /*double check*/
 428             fatal("Permission denied");
 429 #else
 430         /* If we can swap euid and uid, then we can determine access rights
 431          * with a simple stat of the file, and then compare device and
 432          * inode to make sure we did stat() on the same file we opened.
 433          * Then we just have to make sure he or she can execute it.
 434          */
 435         {
 436             struct stat tmpstatbuf;
 437
 438             if (setreuid(euid,uid) < 0 || getuid() != euid || geteuid() != uid)
 439                 fatal("Can't swap uid and euid");       /* really paranoid */
 440             if (stat(stab_val(curcmd->c_filestab)->str_ptr,&tmpstatbuf) < 0)
 441                 fatal("Permission denied");     /* testing full pathname here */
 442             if (tmpstatbuf.st_dev != statbuf.st_dev ||
 443                 tmpstatbuf.st_ino != statbuf.st_ino) {
 444                 (void)fclose(rsfp);
 445                 if (rsfp = mypopen("/bin/mail root","w")) {     /* heh, heh */
 446                     fprintf(rsfp,
 447 "User %d tried to run dev %d ino %d in place of dev %d ino %d!\n\
 448 (Filename of set-id script was %s, uid %d gid %d.)\n\nSincerely,\nperl\n",
 449                         uid,tmpstatbuf.st_dev, tmpstatbuf.st_ino,
 450                         statbuf.st_dev, statbuf.st_ino,
 451                         stab_val(curcmd->c_filestab)->str_ptr,
 452                         statbuf.st_uid, statbuf.st_gid);
 453                     (void)mypclose(rsfp);
 454                 }
 455                 fatal("Permission denied\n");
 456             }
 457             if (setreuid(uid,euid) < 0 || getuid() != uid || geteuid() != euid)
 458                 fatal("Can't reswap uid and euid");
 459             if (!cando(S_IXUSR,FALSE,&statbuf))         /* can real uid exec? */
 460                 fatal("Permission denied\n");
 461         }
 462 #endif /* HAS_SETREUID */
 463 #endif /* IAMSUID */
 464
 465         if (!S_ISREG(statbuf.st_mode))
 466             fatal("Permission denied");
 467         if (statbuf.st_mode & S_IWOTH)
 468             fatal("Setuid/gid script is writable by world");
 469         doswitches = FALSE;             /* -s is insecure in suid */
 470         curcmd->c_line++;
 471         if (fgets(tokenbuf,sizeof tokenbuf, rsfp) == Nullch ||
 472           strnNE(tokenbuf,"#!",2) )     /* required even on Sys V */
 473             fatal("No #! line");
 474         s = tokenbuf+2;
 475         if (*s == ' ') s++;
 476         while (!isspace(*s)) s++;
 477         if (strnNE(s-4,"perl",4) && strnNE(s-9,"perl",4))  /* sanity check */
 478             fatal("Not a perl script");
 479         while (*s == ' ' || *s == '\t') s++;
 480         /*
 481          * #! arg must be what we saw above.  They can invoke it by
 482          * mentioning suidperl explicitly, but they may not add any strange
 483          * arguments beyond what #! says if they do invoke suidperl that way.
 484          */
 485         len = strlen(validarg);
 486         if (strEQ(validarg," PHOOEY ") ||
 487             strnNE(s,validarg,len) || !isspace(s[len]))
 488             fatal("Args must match #! line");
 489
 490 #ifndef IAMSUID
 491         if (euid != uid && (statbuf.st_mode & S_ISUID) &&
 492             euid == statbuf.st_uid)
 493             if (!do_undump)
 494                 fatal("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
 495 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
 496 #endif /* IAMSUID */
 497
 498         if (euid) {     /* oops, we're not the setuid root perl */
 499             (void)fclose(rsfp);
 500 #ifndef IAMSUID
 501             (void)sprintf(buf, "%s/sperl%s", BIN, patchlevel);
 502             execv(buf, origargv);       /* try again */
 503 #endif
 504             fatal("Can't do setuid\n");
 505         }
 506
 507         if (statbuf.st_mode & S_ISGID && statbuf.st_gid != egid)
 508 #ifdef HAS_SETEGID
 509             (void)setegid(statbuf.st_gid);
 510 #else
 511 #ifdef HAS_SETREGID
 512             (void)setregid((GIDTYPE)-1,statbuf.st_gid);
 513 #else
 514             setgid(statbuf.st_gid);
 515 #endif
 516 #endif
 517         if (statbuf.st_mode & S_ISUID) {
 518             if (statbuf.st_uid != euid)
 519 #ifdef HAS_SETEUID
 520                 (void)seteuid(statbuf.st_uid);  /* all that for this */
 521 #else
 522 #ifdef HAS_SETREUID
 523                 (void)setreuid((UIDTYPE)-1,statbuf.st_uid);
 524 #else
 525                 setuid(statbuf.st_uid);
 526 #endif
 527 #endif
 528         }
 529         else if (uid)                   /* oops, mustn't run as root */
 530 #ifdef HAS_SETEUID
 531             (void)seteuid((UIDTYPE)uid);
 532 #else
 533 #ifdef HAS_SETREUID
 534             (void)setreuid((UIDTYPE)-1,(UIDTYPE)uid);
 535 #else
 536             setuid((UIDTYPE)uid);
 537 #endif
 538 #endif
 539         uid = (int)getuid();
 540         euid = (int)geteuid();
 541         gid = (int)getgid();
 542         egid = (int)getegid();
 543         if (!cando(S_IXUSR,TRUE,&statbuf))
 544             fatal("Permission denied\n");       /* they can't do this */
 545     }
 546 #ifdef IAMSUID
 547     else if (preprocess)
 548         fatal("-P not allowed for setuid/setgid script\n");
 549     else
 550         fatal("Script is not setuid/setgid in suidperl\n");
 551 #else
 552 #ifndef TAINT           /* we aren't taintperl or suidperl */
 553     /* script has a wrapper--can't run suidperl or we lose euid */
 554     else if (euid != uid || egid != gid) {
 555         (void)fclose(rsfp);
 556         (void)sprintf(buf, "%s/tperl%s", BIN, patchlevel);
 557         execv(buf, origargv);   /* try again */
 558         fatal("Can't run setuid script with taint checks");
 559     }
 560 #endif /* TAINT */
 561 #endif /* IAMSUID */
 562 #else /* !DOSUID */
 563 #ifndef TAINT           /* we aren't taintperl or suidperl */
 564     if (euid != uid || egid != gid) {   /* (suidperl doesn't exist, in fact) */
 565 #ifndef SETUID_SCRIPTS_ARE_SECURE_NOW
 566         fstat(fileno(rsfp),&statbuf);   /* may be either wrapped or real suid */
 567         if ((euid != uid && euid == statbuf.st_uid && statbuf.st_mode & S_ISUID)
 568             ||
 569             (egid != gid && egid == statbuf.st_gid && statbuf.st_mode & S_ISGID)
 570            )
 571             if (!do_undump)
 572                 fatal("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
 573 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
 574 #endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
 575         /* not set-id, must be wrapped */
 576         (void)fclose(rsfp);
 577         (void)sprintf(buf, "%s/tperl%s", BIN, patchlevel);
 578         execv(buf, origargv);   /* try again */
 579         fatal("Can't run setuid script with taint checks");
 580     }
 581 #endif /* TAINT */
 582 #endif /* DOSUID */
 583
 584 #if !defined(IAMSUID) && !defined(TAINT)
 585
 586     /* skip forward in input to the real script? */
 587
 588     while (doextract) {
 589         if ((s = str_gets(linestr, rsfp, 0)) == Nullch)
 590             fatal("No Perl script found in input\n");
 591         if (*s == '#' && s[1] == '!' && instr(s,"perl")) {
 592             ungetc('\n',rsfp);          /* to keep line count right */
 593             doextract = FALSE;
 594             if (s = instr(s,"perl -")) {
 595                 s += 6;
 596                 while (s = moreswitches(s)) ;
 597             }
 598             if (cddir && chdir(cddir) < 0)
 599                 fatal("Can't chdir to %s",cddir);
 600         }
 601     }
 602 #endif /* !defined(IAMSUID) && !defined(TAINT) */
 603
 604     defstab = stabent("_",TRUE);
 605
 606     if (perldb) {
 607         debstash = hnew(0);
 608         stab_xhash(stabent("_DB",TRUE)) = debstash;
 609         curstash = debstash;
 610         dbargs = stab_xarray(aadd((tmpstab = stabent("args",TRUE))));
 611         tmpstab->str_pok |= SP_MULTI;
 612         dbargs->ary_flags = 0;
 613         subname = str_make("main",4);
 614         DBstab = stabent("DB",TRUE);
 615         DBstab->str_pok |= SP_MULTI;
 616         DBline = stabent("dbline",TRUE);
 617         DBline->str_pok |= SP_MULTI;
 618         DBsub = hadd(tmpstab = stabent("sub",TRUE));
 619         tmpstab->str_pok |= SP_MULTI;
 620         DBsingle = stab_val((tmpstab = stabent("single",TRUE)));
 621         tmpstab->str_pok |= SP_MULTI;
 622         DBtrace = stab_val((tmpstab = stabent("trace",TRUE)));
 623         tmpstab->str_pok |= SP_MULTI;
 624         DBsignal = stab_val((tmpstab = stabent("signal",TRUE)));
 625         tmpstab->str_pok |= SP_MULTI;
 626         curstash = defstash;
 627     }
 628
 629     /* init tokener */
 630
 631     bufend = bufptr = str_get(linestr);
 632
 633     savestack = anew(Nullstab);         /* for saving non-local values */
 634     stack = anew(Nullstab);             /* for saving non-local values */
 635     stack->ary_flags = 0;               /* not a real array */
 636     afill(stack,63); afill(stack,-1);   /* preextend stack */
 637     afill(savestack,63); afill(savestack,-1);
 638
 639     /* now parse the script */
 640
 641     error_count = 0;
 642     if (yyparse() || error_count) {
 643         if (minus_c)
 644             fatal("%s had compilation errors.\n", origfilename);
 645         else {
 646             fatal("Execution of %s aborted due to compilation errors.\n",
 647                 origfilename);
 648         }
 649     }
 650
 651     New(50,loop_stack,128,struct loop);
 652 #ifdef DEBUGGING
 653     if (debug) {
 654         New(51,debname,128,char);
 655         New(52,debdelim,128,char);
 656     }
 657 #endif
 658     curstash = defstash;
 659
 660     preprocess = FALSE;
 661     if (e_fp) {
 662         e_fp = Nullfp;
 663         (void)UNLINK(e_tmpname);
 664     }
 665
 666     /* initialize everything that won't change if we undump */
 667
 668     if (sigstab = stabent("SIG",allstabs)) {
 669         sigstab->str_pok |= SP_MULTI;
 670         (void)hadd(sigstab);
 671     }
 672
 673     magicalize("!#?^~=-%.+&*()<>,\\/[|`':\004\t\020\024\027\006");
 674     userinit();         /* in case linked C routines want magical variables */
 675
 676     amperstab = stabent("&",allstabs);
 677     leftstab = stabent("`",allstabs);
 678     rightstab = stabent("'",allstabs);
 679     sawampersand = (amperstab || leftstab || rightstab);
 680     if (tmpstab = stabent(":",allstabs))
 681         str_set(STAB_STR(tmpstab),chopset);
 682     if (tmpstab = stabent("\024",allstabs))
 683         time(&basetime);
 684
 685     /* these aren't necessarily magical */
 686     if (tmpstab = stabent(";",allstabs))
 687         str_set(STAB_STR(tmpstab),"\034");
 688     if (tmpstab = stabent("]",allstabs)) {
 689         str = STAB_STR(tmpstab);
 690         str_set(str,rcsid);
 691         str->str_u.str_nval = atof(patchlevel);
 692         str->str_nok = 1;
 693     }
 694     str_nset(stab_val(stabent("\"", TRUE)), " ", 1);
 695
 696     stdinstab = stabent("STDIN",TRUE);
 697     stdinstab->str_pok |= SP_MULTI;
 698     stab_io(stdinstab) = stio_new();
 699     stab_io(stdinstab)->ifp = stdin;
 700     tmpstab = stabent("stdin",TRUE);
 701     stab_io(tmpstab) = stab_io(stdinstab);
 702     tmpstab->str_pok |= SP_MULTI;
 703
 704     tmpstab = stabent("STDOUT",TRUE);
 705     tmpstab->str_pok |= SP_MULTI;
 706     stab_io(tmpstab) = stio_new();
 707     stab_io(tmpstab)->ofp = stab_io(tmpstab)->ifp = stdout;
 708     defoutstab = tmpstab;
 709     tmpstab = stabent("stdout",TRUE);
 710     stab_io(tmpstab) = stab_io(defoutstab);
 711     tmpstab->str_pok |= SP_MULTI;
 712
 713     curoutstab = stabent("STDERR",TRUE);
 714     curoutstab->str_pok |= SP_MULTI;
 715     stab_io(curoutstab) = stio_new();
 716     stab_io(curoutstab)->ofp = stab_io(curoutstab)->ifp = stderr;
 717     tmpstab = stabent("stderr",TRUE);
 718     stab_io(tmpstab) = stab_io(curoutstab);
 719     tmpstab->str_pok |= SP_MULTI;
 720     curoutstab = defoutstab;            /* switch back to STDOUT */
 721
 722     statname = Str_new(66,0);           /* last filename we did stat on */
 723
 724     /* now that script is parsed, we can modify record separator */
 725
 726     rs = nrs;
 727     rslen = nrslen;
 728     rschar = nrschar;
 729     str_nset(stab_val(stabent("/", TRUE)), rs, rslen);
 730
 731     if (do_undump)
 732         my_unexec();
 733
 734   just_doit:            /* come here if running an undumped a.out */
 735     argc--,argv++;      /* skip name of script */
 736     if (doswitches) {
 737         for (; argc > 0 && **argv == '-'; argc--,argv++) {
 738             if (argv[0][1] == '-') {
 739                 argc--,argv++;
 740                 break;
 741             }
 742             if (s = index(argv[0], '=')) {
 743                 *s++ = '\0';
 744                 str_set(stab_val(stabent(argv[0]+1,TRUE)),s);
 745             }
 746             else
 747                 str_numset(stab_val(stabent(argv[0]+1,TRUE)),(double)1.0);
 748         }
 749     }
 750 #ifdef TAINT
 751     tainted = 1;
 752 #endif
 753     if (tmpstab = stabent("0",allstabs)) {
 754         str_set(stab_val(tmpstab),origfilename);
 755         magicname("0", Nullch, 0);
 756     }
 757     if (tmpstab = stabent("\030",allstabs))
 758         str_set(stab_val(tmpstab),origargv[0]);
 759     if (argvstab = stabent("ARGV",allstabs)) {
 760         argvstab->str_pok |= SP_MULTI;
 761         (void)aadd(argvstab);
 762         aclear(stab_array(argvstab));
 763         for (; argc > 0; argc--,argv++) {
 764             (void)apush(stab_array(argvstab),str_make(argv[0],0));
 765         }
 766     }
 767 #ifdef TAINT
 768     (void) stabent("ENV",TRUE);         /* must test PATH and IFS */
 769 #endif
 770     if (envstab = stabent("ENV",allstabs)) {
 771         envstab->str_pok |= SP_MULTI;
 772         (void)hadd(envstab);
 773         hclear(stab_hash(envstab), FALSE);
 774         if (env != environ)
 775             environ[0] = Nullch;
 776         for (; *env; env++) {
 777             if (!(s = index(*env,'=')))
 778                 continue;
 779             *s++ = '\0';
 780             str = str_make(s--,0);
 781             str_magic(str, envstab, 'E', *env, s - *env);
 782             (void)hstore(stab_hash(envstab), *env, s - *env, str, 0);
 783             *s = '=';
 784         }
 785     }
 786 #ifdef TAINT
 787     tainted = 0;
 788 #endif
 789     if (tmpstab = stabent("$",allstabs))
 790         str_numset(STAB_STR(tmpstab),(double)getpid());
 791
 792     if (dowarn) {
 793         stab_check('A','Z');
 794         stab_check('a','z');
 795     }
 796
 797     if (setjmp(top_env))        /* sets goto_targ on longjump */
 798         loop_ptr = -1;          /* start label stack again */
 799
 800 #ifdef DEBUGGING
 801     if (debug & 1024)
 802         dump_all();
 803     if (debug)
 804         fprintf(stderr,"\nEXECUTING...\n\n");
 805 #endif
 806
 807     if (minus_c) {
 808         fprintf(stderr,"%s syntax OK\n", origfilename);
 809         exit(0);
 810     }
 811
 812     /* do it */
 813
 814     (void) cmd_exec(main_root,G_SCALAR,-1);
 815
 816     if (goto_targ)
 817         fatal("Can't find label \"%s\"--aborting",goto_targ);
 818     exit(0);
 819     /* NOTREACHED */
 820 }
 821
 822 void
 823 magicalize(list)
 824 register char *list;
 825 {
 826     char sym[2];
 827
 828     sym[1] = '\0';
 829     while (*sym = *list++)
 830         magicname(sym, Nullch, 0);
 831 }
 832
 833 void
 834 magicname(sym,name,namlen)
 835 char *sym;
 836 char *name;
 837 int namlen;
 838 {
 839     register STAB *stab;
 840
 841     if (stab = stabent(sym,allstabs)) {
 842         stab_flags(stab) = SF_VMAGIC;
 843         str_magic(stab_val(stab), stab, 0, name, namlen);
 844     }
 845 }
 846
 847 void
 848 savelines(array, str)
 849 ARRAY *array;
 850 STR *str;
 851 {
 852     register char *s = str->str_ptr;
 853     register char *send = str->str_ptr + str->str_cur;
 854     register char *t;
 855     register int line = 1;
 856
 857     while (s && s < send) {
 858         STR *tmpstr = Str_new(85,0);
 859
 860         t = index(s, '\n');
 861         if (t)
 862             t++;
 863         else
 864             t = send;
 865
 866         str_nset(tmpstr, s, t - s);
 867         astore(array, line++, tmpstr);
 868         s = t;
 869     }
 870 }
 871
 872 /* this routine is in perl.c by virtue of being sort of an alternate main() */
 873
 874 int
 875 do_eval(str,optype,stash,gimme,arglast)
 876 STR *str;
 877 int optype;
 878 HASH *stash;
 879 int gimme;
 880 int *arglast;
 881 {
 882     STR **st = stack->ary_array;
 883     int retval;
 884     CMD *myroot = Nullcmd;
 885     ARRAY *ar;
 886     int i;
 887     CMD * VOLATILE oldcurcmd = curcmd;
 888     VOLATILE int oldtmps_base = tmps_base;
 889     VOLATILE int oldsave = savestack->ary_fill;
 890     VOLATILE int oldperldb = perldb;
 891     SPAT * VOLATILE oldspat = curspat;
 892     SPAT * VOLATILE oldlspat = lastspat;
 893     static char *last_eval = Nullch;
 894     static CMD *last_root = Nullcmd;
 895     VOLATILE int sp = arglast[0];
 896     char *specfilename;
 897     char *tmpfilename;
 898     int parsing = 1;
 899
 900     tmps_base = tmps_max;
 901     if (curstash != stash) {
 902         (void)savehptr(&curstash);
 903         curstash = stash;
 904     }
 905     str_set(stab_val(stabent("@",TRUE)),"");
 906     if (curcmd->c_line == 0)            /* don't debug debugger... */
 907         perldb = FALSE;
 908     curcmd = &compiling;
 909     if (optype == O_EVAL) {             /* normal eval */
 910         curcmd->c_filestab = fstab("(eval)");
 911         curcmd->c_line = 1;
 912         str_sset(linestr,str);
 913         str_cat(linestr,";\n");         /* be kind to them */
 914         if (perldb)
 915             savelines(stab_xarray(curcmd->c_filestab), linestr);
 916     }
 917     else {
 918         if (last_root && !in_eval) {
 919             Safefree(last_eval);
 920             last_eval = Nullch;
 921             cmd_free(last_root);
 922             last_root = Nullcmd;
 923         }
 924         specfilename = str_get(str);
 925         str_set(linestr,"");
 926         if (optype == O_REQUIRE && &str_undef !=
 927           hfetch(stab_hash(incstab), specfilename, strlen(specfilename), 0)) {
 928             curcmd = oldcurcmd;
 929             tmps_base = oldtmps_base;
 930             st[++sp] = &str_yes;
 931             perldb = oldperldb;
 932             return sp;
 933         }
 934         tmpfilename = savestr(specfilename);
 935         if (index("/.", *tmpfilename))
 936             rsfp = fopen(tmpfilename,"r");
 937         else {
 938             ar = stab_array(incstab);
 939             for (i = 0; i <= ar->ary_fill; i++) {
 940                 (void)sprintf(buf, "%s/%s",
 941                   str_get(afetch(ar,i,TRUE)), specfilename);
 942                 rsfp = fopen(buf,"r");
 943                 if (rsfp) {
 944                     char *s = buf;
 945
 946                     if (*s == '.' && s[1] == '/')
 947                         s += 2;
 948                     Safefree(tmpfilename);
 949                     tmpfilename = savestr(s);
 950                     break;
 951                 }
 952             }
 953         }
 954         curcmd->c_filestab = fstab(tmpfilename);
 955         Safefree(tmpfilename);
 956         tmpfilename = Nullch;
 957         if (!rsfp) {
 958             curcmd = oldcurcmd;
 959             tmps_base = oldtmps_base;
 960             if (optype == O_REQUIRE) {
 961                 sprintf(tokenbuf,"Can't locate %s in @INC", specfilename);
 962                 if (instr(tokenbuf,".h "))
 963                     strcat(tokenbuf," (change .h to .ph maybe?)");
 964                 if (instr(tokenbuf,".ph "))
 965                     strcat(tokenbuf," (did you run h2ph?)");
 966                 fatal("%s",tokenbuf);
 967             }
 968             if (gimme != G_ARRAY)
 969                 st[++sp] = &str_undef;
 970             perldb = oldperldb;
 971             return sp;
 972         }
 973         curcmd->c_line = 0;
 974     }
 975     in_eval++;
 976     oldoldbufptr = oldbufptr = bufptr = str_get(linestr);
 977     bufend = bufptr + linestr->str_cur;
 978     if (++loop_ptr >= loop_max) {
 979         loop_max += 128;
 980         Renew(loop_stack, loop_max, struct loop);
 981     }
 982     loop_stack[loop_ptr].loop_label = "_EVAL_";
 983     loop_stack[loop_ptr].loop_sp = sp;
 984 #ifdef DEBUGGING
 985     if (debug & 4) {
 986         deb("(Pushing label #%d _EVAL_)\n", loop_ptr);
 987     }
 988 #endif
 989     eval_root = Nullcmd;
 990     if (setjmp(loop_stack[loop_ptr].loop_env)) {
 991         retval = 1;
 992     }
 993     else {
 994         error_count = 0;
 995         if (rsfp) {
 996             retval = yyparse();
 997             retval |= error_count;
 998         }
 999         else if (last_root && *bufptr == *last_eval && strEQ(bufptr,last_eval)){
1000             retval = 0;
1001             eval_root = last_root;      /* no point in reparsing */
1002         }
1003         else if (in_eval == 1) {
1004             if (last_root) {
1005                 Safefree(last_eval);
1006                 last_eval = Nullch;
1007                 cmd_free(last_root);
1008             }
1009             last_root = Nullcmd;
1010             last_eval = savestr(bufptr);
1011             retval = yyparse();
1012             retval |= error_count;
1013             if (!retval)
1014                 last_root = eval_root;
1015             if (!last_root) {
1016                 Safefree(last_eval);
1017                 last_eval = Nullch;
1018             }
1019         }
1020         else
1021             retval = yyparse();
1022     }
1023     myroot = eval_root;         /* in case cmd_exec does another eval! */
1024
1025     if (retval) {
1026         st = stack->ary_array;
1027         sp = arglast[0];
1028         if (gimme != G_ARRAY)
1029             st[++sp] = &str_undef;
1030         if (parsing) {
1031 #ifndef MANGLEDPARSE
1032 #ifdef DEBUGGING
1033             if (debug & 128)
1034                 fprintf(stderr,"Freeing eval_root %lx\n",(long)eval_root);
1035 #endif
1036             cmd_free(eval_root);
1037 #endif
1038             if (eval_root == last_root)
1039                 last_root = Nullcmd;
1040             eval_root = myroot = Nullcmd;
1041         }
1042         if (rsfp) {
1043             fclose(rsfp);
1044             rsfp = 0;
1045         }
1046     }
1047     else {
1048         parsing = 0;
1049         sp = cmd_exec(eval_root,gimme,sp);
1050         st = stack->ary_array;
1051         for (i = arglast[0] + 1; i <= sp; i++)
1052             st[i] = str_mortal(st[i]);
1053                                 /* if we don't save result, free zaps it */
1054         if (in_eval != 1 && myroot != last_root)
1055             cmd_free(myroot);
1056     }
1057
1058     perldb = oldperldb;
1059     in_eval--;
1060 #ifdef DEBUGGING
1061     if (debug & 4) {
1062         char *tmps = loop_stack[loop_ptr].loop_label;
1063         deb("(Popping label #%d %s)\n",loop_ptr,
1064             tmps ? tmps : "" );
1065     }
1066 #endif
1067     loop_ptr--;
1068     tmps_base = oldtmps_base;
1069     curspat = oldspat;
1070     lastspat = oldlspat;
1071     if (savestack->ary_fill > oldsave)  /* let them use local() */
1072         restorelist(oldsave);
1073
1074     if (optype != O_EVAL) {
1075         if (retval) {
1076             if (optype == O_REQUIRE)
1077                 fatal("%s", str_get(stab_val(stabent("@",TRUE))));
1078         }
1079         else {
1080             curcmd = oldcurcmd;
1081             if (gimme == G_SCALAR ? str_true(st[sp]) : sp > arglast[0]) {
1082                 (void)hstore(stab_hash(incstab), specfilename,
1083                   strlen(specfilename), str_smake(stab_val(curcmd->c_filestab)),
1084                       0 );
1085             }
1086             else if (optype == O_REQUIRE)
1087                 fatal("%s did not return a true value", specfilename);
1088         }
1089     }
1090     curcmd = oldcurcmd;
1091     return sp;
1092 }
1093
1094 /* This routine handles any switches that can be given during run */
1095
1096 static char *
1097 moreswitches(s)
1098 char *s;
1099 {
1100     int numlen;
1101
1102   reswitch:
1103     switch (*s) {
1104     case '0':
1105         nrschar = scanoct(s, 4, &numlen);
1106         nrs = nsavestr("\n",1);
1107         *nrs = nrschar;
1108         if (nrschar > 0377) {
1109             nrslen = 0;
1110             nrs = "";
1111         }
1112         else if (!nrschar && numlen >= 2) {
1113             nrslen = 2;
1114             nrs = "\n\n";
1115             nrschar = '\n';
1116         }
1117         return s + numlen;
1118     case 'a':
1119         minus_a = TRUE;
1120         s++;
1121         return s;
1122     case 'c':
1123         minus_c = TRUE;
1124         s++;
1125         return s;
1126     case 'd':
1127 #ifdef TAINT
1128         if (euid != uid || egid != gid)
1129             fatal("No -d allowed in setuid scripts");
1130 #endif
1131         perldb = TRUE;
1132         s++;
1133         return s;
1134     case 'D':
1135 #ifdef DEBUGGING
1136 #ifdef TAINT
1137         if (euid != uid || egid != gid)
1138             fatal("No -D allowed in setuid scripts");
1139 #endif
1140         debug = atoi(s+1) | 32768;
1141 #else
1142         warn("Recompile perl with -DDEBUGGING to use -D switch\n");
1143 #endif
1144         for (s++; isdigit(*s); s++) ;
1145         return s;
1146     case 'i':
1147         inplace = savestr(s+1);
1148         for (s = inplace; *s && !isspace(*s); s++) ;
1149         *s = '\0';
1150         break;
1151     case 'I':
1152 #ifdef TAINT
1153         if (euid != uid || egid != gid)
1154             fatal("No -I allowed in setuid scripts");
1155 #endif
1156         if (*++s) {
1157             (void)apush(stab_array(incstab),str_make(s,0));
1158         }
1159         else
1160             fatal("No space allowed after -I");
1161         break;
1162     case 'l':
1163         minus_l = TRUE;
1164         s++;
1165         if (isdigit(*s)) {
1166             ors = savestr("\n");
1167             orslen = 1;
1168             *ors = scanoct(s, 3 + (*s == '0'), &numlen);
1169             s += numlen;
1170         }
1171         else {
1172             ors = nsavestr(nrs,nrslen);
1173             orslen = nrslen;
1174         }
1175         return s;
1176     case 'n':
1177         minus_n = TRUE;
1178         s++;
1179         return s;
1180     case 'p':
1181         minus_p = TRUE;
1182         s++;
1183         return s;
1184     case 'u':
1185         do_undump = TRUE;
1186         s++;
1187         return s;
1188     case 'U':
1189         unsafe = TRUE;
1190         s++;
1191         return s;
1192     case 'v':
1193         fputs("\nThis is perl, version 4.0\n\n",stdout);
1194         fputs(rcsid,stdout);
1195         fputs("\nCopyright (c) 1989, 1990, 1991, Larry Wall\n",stdout);
1196 #ifdef MSDOS
1197         fputs("MS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n",
1198         stdout);
1199 #ifdef OS2
1200         fputs("OS/2 port Copyright (c) 1990, Raymond Chen, Kai Uwe Rommel\n",
1201         stdout);
1202 #endif
1203 #endif
1204         fputs("\n\
1205 Perl may be copied only under the terms of either the Artistic License or the\n\
1206 GNU General Public License, which may be found in the Perl 4.0 source kit.\n",stdout);
1207 #ifdef MSDOS
1208         usage(origargv[0]);
1209 #endif
1210         exit(0);
1211     case 'w':
1212         dowarn = TRUE;
1213         s++;
1214         return s;
1215     case ' ':
1216     case '\n':
1217     case '\t':
1218         break;
1219     default:
1220         fatal("Switch meaningless after -x: -%s",s);
1221     }
1222     return Nullch;
1223 }
1224
1225 /* compliments of Tom Christiansen */
1226
1227 /* unexec() can be found in the Gnu emacs distribution */
1228
1229 my_unexec()
1230 {
1231 #ifdef UNEXEC
1232     int    status;
1233     extern int etext;
1234     static char dumpname[BUFSIZ];
1235     static char perlpath[256];
1236
1237     sprintf (dumpname, "%s.perldump", origfilename);
1238     sprintf (perlpath, "%s/perl", BIN);
1239
1240     status = unexec(dumpname, perlpath, &etext, sbrk(0), 0);
1241     if (status)
1242         fprintf(stderr, "unexec of %s into %s failed!\n", perlpath, dumpname);
1243     exit(status);
1244 #else
1245 #ifdef MSDOS
1246     abort();    /* nothing else to do */
1247 #else /* ! MSDOS */
1248 #   ifndef SIGABRT
1249 #       define SIGABRT SIGILL
1250 #   endif
1251 #   ifndef SIGILL
1252 #       define SIGILL 6         /* blech */
1253 #   endif
1254     kill(getpid(),SIGABRT);     /* for use with undump */
1255 #endif /* ! MSDOS */
1256 #endif
1257 }
1258