perl.c

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