perl.c

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