perl.c

   1 /*    perl.c
   2  *
   3  *    Copyright (c) 1987-1997 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  */
   9
  10 /*
  11  * "A ship then new they built for him/of mithril and of elven glass" --Bilbo
  12  */
  13
  14 #include "EXTERN.h"
  15 #include "perl.h"
  16 #include "patchlevel.h"
  17
  18 /* XXX If this causes problems, set i_unistd=undef in the hint file.  */
  19 #ifdef I_UNISTD
  20 #include <unistd.h>
  21 #endif
  22
  23 #if !defined(STANDARD_C) && !defined(HAS_GETENV_PROTOTYPE)
  24 char *getenv _((char *)); /* Usually in <stdlib.h> */
  25 #endif
  26
  27 dEXTCONST char rcsid[] = "perl.c\nPatch level: ###\n";
  28
  29 #ifdef IAMSUID
  30 #ifndef DOSUID
  31 #define DOSUID
  32 #endif
  33 #endif
  34
  35 #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
  36 #ifdef DOSUID
  37 #undef DOSUID
  38 #endif
  39 #endif
  40
  41 #define I_REINIT \
  42   STMT_START {                  \
  43     chopset     = " \n-";       \
  44     copline     = NOLINE;       \
  45     curcop      = &compiling;   \
  46     curcopdb    = NULL;         \
  47     cxstack_ix  = -1;           \
  48     cxstack_max = 128;          \
  49     dbargs      = 0;            \
  50     dlmax       = 128;          \
  51     laststatval = -1;           \
  52     laststype   = OP_STAT;      \
  53     maxscream   = -1;           \
  54     maxsysfd    = MAXSYSFD;     \
  55     statname    = Nullsv;       \
  56     tmps_floor  = -1;           \
  57     tmps_ix     = -1;           \
  58     op_mask     = NULL;         \
  59     dlmax       = 128;          \
  60     laststatval = -1;           \
  61     laststype   = OP_STAT;      \
  62     mess_sv     = Nullsv;       \
  63   } STMT_END
  64
  65 static void find_beginning _((void));
  66 static void forbid_setid _((char *));
  67 static void incpush _((char *, int));
  68 static void init_ids _((void));
  69 static void init_debugger _((void));
  70 static void init_lexer _((void));
  71 static void init_main_stash _((void));
  72 static void init_perllib _((void));
  73 static void init_postdump_symbols _((int, char **, char **));
  74 static void init_predump_symbols _((void));
  75 static void init_stacks _((void));
  76 static void my_exit_jump _((void)) __attribute__((noreturn));
  77 static void nuke_stacks _((void));
  78 static void open_script _((char *, bool, SV *));
  79 static void usage _((char *));
  80 static void validate_suid _((char *, char*));
  81
  82 static int fdscript = -1;
  83
  84 PerlInterpreter *
  85 perl_alloc()
  86 {
  87     PerlInterpreter *sv_interp;
  88
  89     curinterp = 0;
  90     New(53, sv_interp, 1, PerlInterpreter);
  91     return sv_interp;
  92 }
  93
  94 void
  95 perl_construct( sv_interp )
  96 register PerlInterpreter *sv_interp;
  97 {
  98     if (!(curinterp = sv_interp))
  99         return;
 100
 101 #ifdef MULTIPLICITY
 102     Zero(sv_interp, 1, PerlInterpreter);
 103 #endif
 104
 105     /* Init the real globals? */
 106     if (!linestr) {
 107         linestr = NEWSV(65,80);
 108         sv_upgrade(linestr,SVt_PVIV);
 109
 110         if (!SvREADONLY(&sv_undef)) {
 111             SvREADONLY_on(&sv_undef);
 112
 113             sv_setpv(&sv_no,No);
 114             SvNV(&sv_no);
 115             SvREADONLY_on(&sv_no);
 116
 117             sv_setpv(&sv_yes,Yes);
 118             SvNV(&sv_yes);
 119             SvREADONLY_on(&sv_yes);
 120         }
 121
 122         nrs = newSVpv("\n", 1);
 123         rs = SvREFCNT_inc(nrs);
 124
 125         pidstatus = newHV();
 126
 127 #ifdef MSDOS
 128         /*
 129          * There is no way we can refer to them from Perl so close them to save
 130          * space.  The other alternative would be to provide STDAUX and STDPRN
 131          * filehandles.
 132          */
 133         (void)fclose(stdaux);
 134         (void)fclose(stdprn);
 135 #endif
 136     }
 137
 138 #ifdef MULTIPLICITY
 139     I_REINIT;
 140     perl_destruct_level = 1;
 141 #else
 142    if(perl_destruct_level > 0)
 143        I_REINIT;
 144 #endif
 145
 146     init_ids();
 147     lex_state = LEX_NOTPARSING;
 148
 149     start_env.je_prev = NULL;
 150     start_env.je_ret = -1;
 151     start_env.je_mustcatch = TRUE;
 152     top_env     = &start_env;
 153     STATUS_ALL_SUCCESS;
 154
 155     SET_NUMERIC_STANDARD();
 156 #if defined(SUBVERSION) && SUBVERSION > 0
 157     sprintf(patchlevel, "%7.5f",   (double) 5
 158                                 + ((double) PATCHLEVEL / (double) 1000)
 159                                 + ((double) SUBVERSION / (double) 100000));
 160 #else
 161     sprintf(patchlevel, "%5.3f", (double) 5 +
 162                                 ((double) PATCHLEVEL / (double) 1000));
 163 #endif
 164
 165 #if defined(LOCAL_PATCH_COUNT)
 166     localpatches = local_patches;       /* For possible -v */
 167 #endif
 168
 169     PerlIO_init();      /* Hook to IO system */
 170
 171     fdpid = newAV();    /* for remembering popen pids by fd */
 172
 173     init_stacks();
 174     ENTER;
 175 }
 176
 177 void
 178 perl_destruct(sv_interp)
 179 register PerlInterpreter *sv_interp;
 180 {
 181     int destruct_level;  /* 0=none, 1=full, 2=full with checks */
 182     I32 last_sv_count;
 183     HV *hv;
 184
 185     if (!(curinterp = sv_interp))
 186         return;
 187
 188     destruct_level = perl_destruct_level;
 189 #ifdef DEBUGGING
 190     {
 191         char *s;
 192         if (s = getenv("PERL_DESTRUCT_LEVEL")) {
 193             int i = atoi(s);
 194             if (destruct_level < i)
 195                 destruct_level = i;
 196         }
 197     }
 198 #endif
 199
 200     LEAVE;
 201     FREETMPS;
 202
 203     /* We must account for everything.  */
 204
 205     /* Destroy the main CV and syntax tree */
 206     if (main_root) {
 207         curpad = AvARRAY(comppad);
 208         op_free(main_root);
 209         main_root = Nullop;
 210     }
 211     main_start = Nullop;
 212     SvREFCNT_dec(main_cv);
 213     main_cv = Nullcv;
 214
 215     if (sv_objcount) {
 216         /*
 217          * Try to destruct global references.  We do this first so that the
 218          * destructors and destructees still exist.  Some sv's might remain.
 219          * Non-referenced objects are on their own.
 220          */
 221
 222         dirty = TRUE;
 223         sv_clean_objs();
 224     }
 225
 226     /* unhook hooks which will soon be, or use, destroyed data */
 227     SvREFCNT_dec(warnhook);
 228     warnhook = Nullsv;
 229     SvREFCNT_dec(diehook);
 230     diehook = Nullsv;
 231     SvREFCNT_dec(parsehook);
 232     parsehook = Nullsv;
 233
 234     if (destruct_level == 0){
 235
 236         DEBUG_P(debprofdump());
 237
 238         /* The exit() function will do everything that needs doing. */
 239         return;
 240     }
 241
 242     /* loosen bonds of global variables */
 243
 244     if(rsfp) {
 245         (void)PerlIO_close(rsfp);
 246         rsfp = Nullfp;
 247     }
 248
 249     /* Filters for program text */
 250     SvREFCNT_dec(rsfp_filters);
 251     rsfp_filters = Nullav;
 252
 253     /* switches */
 254     preprocess   = FALSE;
 255     minus_n      = FALSE;
 256     minus_p      = FALSE;
 257     minus_l      = FALSE;
 258     minus_a      = FALSE;
 259     minus_F      = FALSE;
 260     doswitches   = FALSE;
 261     dowarn       = FALSE;
 262     doextract    = FALSE;
 263     sawampersand = FALSE;       /* must save all match strings */
 264     sawstudy     = FALSE;       /* do fbm_instr on all strings */
 265     sawvec       = FALSE;
 266     unsafe       = FALSE;
 267
 268     Safefree(inplace);
 269     inplace = Nullch;
 270
 271     Safefree(e_tmpname);
 272     e_tmpname = Nullch;
 273
 274     if (e_fp) {
 275         PerlIO_close(e_fp);
 276         e_fp = Nullfp;
 277     }
 278
 279     /* magical thingies */
 280
 281     Safefree(ofs);      /* $, */
 282     ofs = Nullch;
 283
 284     Safefree(ors);      /* $\ */
 285     ors = Nullch;
 286
 287     SvREFCNT_dec(nrs);  /* $\ helper */
 288     nrs = Nullsv;
 289
 290     multiline = 0;      /* $* */
 291
 292     SvREFCNT_dec(statname);
 293     statname = Nullsv;
 294     statgv = Nullgv;
 295
 296     /* defgv, aka *_ should be taken care of elsewhere */
 297
 298 #if 0  /* just about all regexp stuff, seems to be ok */
 299
 300     /* shortcuts to regexp stuff */
 301     leftgv = Nullgv;
 302     ampergv = Nullgv;
 303
 304     SAVEFREEOP(curpm);
 305     SAVEFREEOP(oldlastpm); /* for saving regexp context during debugger */
 306
 307     regprecomp = NULL;  /* uncompiled string. */
 308     regparse = NULL;    /* Input-scan pointer. */
 309     regxend = NULL;     /* End of input for compile */
 310     regnpar = 0;        /* () count. */
 311     regcode = NULL;     /* Code-emit pointer; &regdummy = don't. */
 312     regsize = 0;        /* Code size. */
 313     regnaughty = 0;     /* How bad is this pattern? */
 314     regsawback = 0;     /* Did we see \1, ...? */
 315
 316     reginput = NULL;            /* String-input pointer. */
 317     regbol = NULL;              /* Beginning of input, for ^ check. */
 318     regeol = NULL;              /* End of input, for $ check. */
 319     regstartp = (char **)NULL;  /* Pointer to startp array. */
 320     regendp = (char **)NULL;    /* Ditto for endp. */
 321     reglastparen = 0;           /* Similarly for lastparen. */
 322     regtill = NULL;             /* How far we are required to go. */
 323     regflags = 0;               /* are we folding, multilining? */
 324     regprev = (char)NULL;       /* char before regbol, \n if none */
 325
 326 #endif /* if 0 */
 327
 328     /* clean up after study() */
 329     SvREFCNT_dec(lastscream);
 330     lastscream = Nullsv;
 331     Safefree(screamfirst);
 332     screamfirst = 0;
 333     Safefree(screamnext);
 334     screamnext  = 0;
 335
 336     /* startup and shutdown function lists */
 337     SvREFCNT_dec(beginav);
 338     SvREFCNT_dec(endav);
 339     beginav = Nullav;
 340     endav = Nullav;
 341
 342     /* temp stack during pp_sort() */
 343     SvREFCNT_dec(sortstack);
 344     sortstack = Nullav;
 345
 346     /* shortcuts just get cleared */
 347     envgv = Nullgv;
 348     siggv = Nullgv;
 349     incgv = Nullgv;
 350     errgv = Nullgv;
 351     argvgv = Nullgv;
 352     argvoutgv = Nullgv;
 353     stdingv = Nullgv;
 354     last_in_gv = Nullgv;
 355
 356     /* reset so print() ends up where we expect */
 357     setdefout(Nullgv);
 358
 359     /* Prepare to destruct main symbol table.  */
 360
 361     hv = defstash;
 362     defstash = 0;
 363     SvREFCNT_dec(hv);
 364
 365     FREETMPS;
 366     if (destruct_level >= 2) {
 367         if (scopestack_ix != 0)
 368             warn("Unbalanced scopes: %ld more ENTERs than LEAVEs\n",
 369                  (long)scopestack_ix);
 370         if (savestack_ix != 0)
 371             warn("Unbalanced saves: %ld more saves than restores\n",
 372                  (long)savestack_ix);
 373         if (tmps_floor != -1)
 374             warn("Unbalanced tmps: %ld more allocs than frees\n",
 375                  (long)tmps_floor + 1);
 376         if (cxstack_ix != -1)
 377             warn("Unbalanced context: %ld more PUSHes than POPs\n",
 378                  (long)cxstack_ix + 1);
 379     }
 380
 381     /* Now absolutely destruct everything, somehow or other, loops or no. */
 382     last_sv_count = 0;
 383     SvFLAGS(strtab) |= SVTYPEMASK;              /* don't clean out strtab now */
 384     while (sv_count != 0 && sv_count != last_sv_count) {
 385         last_sv_count = sv_count;
 386         sv_clean_all();
 387     }
 388     SvFLAGS(strtab) &= ~SVTYPEMASK;
 389     SvFLAGS(strtab) |= SVt_PVHV;
 390
 391     /* Destruct the global string table. */
 392     {
 393         /* Yell and reset the HeVAL() slots that are still holding refcounts,
 394          * so that sv_free() won't fail on them.
 395          */
 396         I32 riter;
 397         I32 max;
 398         HE *hent;
 399         HE **array;
 400
 401         riter = 0;
 402         max = HvMAX(strtab);
 403         array = HvARRAY(strtab);
 404         hent = array[0];
 405         for (;;) {
 406             if (hent) {
 407                 warn("Unbalanced string table refcount: (%d) for \"%s\"",
 408                      HeVAL(hent) - Nullsv, HeKEY(hent));
 409                 HeVAL(hent) = Nullsv;
 410                 hent = HeNEXT(hent);
 411             }
 412             if (!hent) {
 413                 if (++riter > max)
 414                     break;
 415                 hent = array[riter];
 416             }
 417         }
 418     }
 419     SvREFCNT_dec(strtab);
 420
 421     if (sv_count != 0)
 422         warn("Scalars leaked: %ld\n", (long)sv_count);
 423
 424     sv_free_arenas();
 425
 426     /* No SVs have survived, need to clean out */
 427     linestr = NULL;
 428     pidstatus = Nullhv;
 429     if (origfilename)
 430         Safefree(origfilename);
 431     nuke_stacks();
 432     hints = 0;          /* Reset hints. Should hints be per-interpreter ? */
 433
 434     DEBUG_P(debprofdump());
 435
 436     /* As the absolutely last thing, free the non-arena SV for mess() */
 437
 438     if (mess_sv) {
 439         /* we know that type >= SVt_PV */
 440         SvOOK_off(mess_sv);
 441         Safefree(SvPVX(mess_sv));
 442         Safefree(SvANY(mess_sv));
 443         Safefree(mess_sv);
 444         mess_sv = Nullsv;
 445     }
 446 }
 447
 448 void
 449 perl_free(sv_interp)
 450 PerlInterpreter *sv_interp;
 451 {
 452     if (!(curinterp = sv_interp))
 453         return;
 454     Safefree(sv_interp);
 455 }
 456
 457 int
 458 perl_parse(sv_interp, xsinit, argc, argv, env)
 459 PerlInterpreter *sv_interp;
 460 void (*xsinit)_((void));
 461 int argc;
 462 char **argv;
 463 char **env;
 464 {
 465     register SV *sv;
 466     register char *s;
 467     char *scriptname = NULL;
 468     VOL bool dosearch = FALSE;
 469     char *validarg = "";
 470     I32 oldscope;
 471     AV* comppadlist;
 472     dJMPENV;
 473     int ret;
 474
 475 #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
 476 #ifdef IAMSUID
 477 #undef IAMSUID
 478     croak("suidperl is no longer needed since the kernel can now execute\n\
 479 setuid perl scripts securely.\n");
 480 #endif
 481 #endif
 482
 483     if (!(curinterp = sv_interp))
 484         return 255;
 485
 486 #if defined(NeXT) && defined(__DYNAMIC__)
 487     _dyld_lookup_and_bind
 488         ("__environ", (unsigned long *) &environ_pointer, NULL);
 489 #endif /* environ */
 490
 491     origargv = argv;
 492     origargc = argc;
 493 #ifndef VMS  /* VMS doesn't have environ array */
 494     origenviron = environ;
 495 #endif
 496     e_tmpname = Nullch;
 497
 498     if (do_undump) {
 499
 500         /* Come here if running an undumped a.out. */
 501
 502         origfilename = savepv(argv[0]);
 503         do_undump = FALSE;
 504         cxstack_ix = -1;                /* start label stack again */
 505         init_ids();
 506         init_postdump_symbols(argc,argv,env);
 507         return 0;
 508     }
 509
 510     if (main_root) {
 511         curpad = AvARRAY(comppad);
 512         op_free(main_root);
 513         main_root = Nullop;
 514     }
 515     main_start = Nullop;
 516     SvREFCNT_dec(main_cv);
 517     main_cv = Nullcv;
 518
 519     time(&basetime);
 520     oldscope = scopestack_ix;
 521
 522     JMPENV_PUSH(ret);
 523     switch (ret) {
 524     case 1:
 525         STATUS_ALL_FAILURE;
 526         /* FALL THROUGH */
 527     case 2:
 528         /* my_exit() was called */
 529         while (scopestack_ix > oldscope)
 530             LEAVE;
 531         FREETMPS;
 532         curstash = defstash;
 533         if (endav)
 534             call_list(oldscope, endav);
 535         JMPENV_POP;
 536         return STATUS_NATIVE_EXPORT;
 537     case 3:
 538         JMPENV_POP;
 539         PerlIO_printf(PerlIO_stderr(), "panic: top_env\n");
 540         return 1;
 541     }
 542
 543     sv_setpvn(linestr,"",0);
 544     sv = newSVpv("",0);         /* first used for -I flags */
 545     SAVEFREESV(sv);
 546     init_main_stash();
 547
 548     for (argc--,argv++; argc > 0; argc--,argv++) {
 549         if (argv[0][0] != '-' || !argv[0][1])
 550             break;
 551 #ifdef DOSUID
 552     if (*validarg)
 553         validarg = " PHOOEY ";
 554     else
 555         validarg = argv[0];
 556 #endif
 557         s = argv[0]+1;
 558       reswitch:
 559         switch (*s) {
 560         case '0':
 561         case 'F':
 562         case 'a':
 563         case 'c':
 564         case 'd':
 565         case 'D':
 566         case 'h':
 567         case 'i':
 568         case 'l':
 569         case 'M':
 570         case 'm':
 571         case 'n':
 572         case 'p':
 573         case 's':
 574         case 'u':
 575         case 'U':
 576         case 'v':
 577         case 'w':
 578             if (s = moreswitches(s))
 579                 goto reswitch;
 580             break;
 581
 582         case 'T':
 583             tainting = TRUE;
 584             s++;
 585             goto reswitch;
 586
 587         case 'e':
 588             if (euid != uid || egid != gid)
 589                 croak("No -e allowed in setuid scripts");
 590             if (!e_fp) {
 591                 e_tmpname = savepv(TMPPATH);
 592                 (void)mktemp(e_tmpname);
 593                 if (!*e_tmpname)
 594                     croak("Can't mktemp()");
 595                 e_fp = PerlIO_open(e_tmpname,"w");
 596                 if (!e_fp)
 597                     croak("Cannot open temporary file");
 598             }
 599             if (*++s)
 600                 PerlIO_puts(e_fp,s);
 601             else if (argv[1]) {
 602                 PerlIO_puts(e_fp,argv[1]);
 603                 argc--,argv++;
 604             }
 605             else
 606                 croak("No code specified for -e");
 607             (void)PerlIO_putc(e_fp,'\n');
 608             break;
 609         case 'I':       /* -I handled both here and in moreswitches() */
 610             forbid_setid("-I");
 611             if (!*++s && (s=argv[1]) != Nullch) {
 612                 argc--,argv++;
 613             }
 614             while (s && isSPACE(*s))
 615                 ++s;
 616             if (s && *s) {
 617                 char *e, *p;
 618                 for (e = s; *e && !isSPACE(*e); e++) ;
 619                 p = savepvn(s, e-s);
 620                 incpush(p, TRUE);
 621                 sv_catpv(sv,"-I");
 622                 sv_catpv(sv,p);
 623                 sv_catpv(sv," ");
 624                 Safefree(p);
 625             }   /* XXX else croak? */
 626             break;
 627         case 'P':
 628             forbid_setid("-P");
 629             preprocess = TRUE;
 630             s++;
 631             goto reswitch;
 632         case 'S':
 633             forbid_setid("-S");
 634             dosearch = TRUE;
 635             s++;
 636             goto reswitch;
 637         case 'V':
 638             if (!preambleav)
 639                 preambleav = newAV();
 640             av_push(preambleav, newSVpv("use Config qw(myconfig config_vars)",0));
 641             if (*++s != ':')  {
 642                 Sv = newSVpv("print myconfig();",0);
 643 #ifdef VMS
 644                 sv_catpv(Sv,"print \"\\nCharacteristics of this PERLSHR image: \\n\",");
 645 #else
 646                 sv_catpv(Sv,"print \"\\nCharacteristics of this binary (from libperl): \\n\",");
 647 #endif
 648 #if defined(DEBUGGING) || defined(NO_EMBED) || defined(MULTIPLICITY)
 649                 sv_catpv(Sv,"\"  Compile-time options:");
 650 #  ifdef DEBUGGING
 651                 sv_catpv(Sv," DEBUGGING");
 652 #  endif
 653 #  ifdef NO_EMBED
 654                 sv_catpv(Sv," NO_EMBED");
 655 #  endif
 656 #  ifdef MULTIPLICITY
 657                 sv_catpv(Sv," MULTIPLICITY");
 658 #  endif
 659                 sv_catpv(Sv,"\\n\",");
 660 #endif
 661 #if defined(LOCAL_PATCH_COUNT)
 662                 if (LOCAL_PATCH_COUNT > 0) {
 663                     int i;
 664                     sv_catpv(Sv,"\"  Locally applied patches:\\n\",");
 665                     for (i = 1; i <= LOCAL_PATCH_COUNT; i++) {
 666                         if (localpatches[i])
 667                             sv_catpvf(Sv,"\"  \\t%s\\n\",",localpatches[i]);
 668                     }
 669                 }
 670 #endif
 671                 sv_catpvf(Sv,"\"  Built under %s\\n\"",OSNAME);
 672 #ifdef __DATE__
 673 #  ifdef __TIME__
 674                 sv_catpvf(Sv,",\"  Compiled at %s %s\\n\"",__DATE__,__TIME__);
 675 #  else
 676                 sv_catpvf(Sv,",\"  Compiled on %s\\n\"",__DATE__);
 677 #  endif
 678 #endif
 679                 sv_catpv(Sv, "; \
 680 $\"=\"\\n    \"; \
 681 @env = map { \"$_=\\\"$ENV{$_}\\\"\" } sort grep {/^PERL/} keys %ENV; \
 682 print \"  \\%ENV:\\n    @env\\n\" if @env; \
 683 print \"  \\@INC:\\n    @INC\\n\";");
 684             }
 685             else {
 686                 Sv = newSVpv("config_vars(qw(",0);
 687                 sv_catpv(Sv, ++s);
 688                 sv_catpv(Sv, "))");
 689                 s += strlen(s);
 690             }
 691             av_push(preambleav, Sv);
 692             scriptname = BIT_BUCKET;    /* don't look for script or read stdin */
 693             goto reswitch;
 694         case 'x':
 695             doextract = TRUE;
 696             s++;
 697             if (*s)
 698                 cddir = savepv(s);
 699             break;
 700         case 0:
 701             break;
 702         case '-':
 703             if (!*++s || isSPACE(*s)) {
 704                 argc--,argv++;
 705                 goto switch_end;
 706             }
 707             /* catch use of gnu style long options */
 708             if (strEQ(s, "version")) {
 709                 s = "v";
 710                 goto reswitch;
 711             }
 712             if (strEQ(s, "help")) {
 713                 s = "h";
 714                 goto reswitch;
 715             }
 716             s--;
 717             /* FALL THROUGH */
 718         default:
 719             croak("Unrecognized switch: -%s  (-h will show valid options)",s);
 720         }
 721     }
 722   switch_end:
 723
 724     if (!tainting && (s = getenv("PERL5OPT"))) {
 725         while (s && *s) {
 726             while (isSPACE(*s))
 727                 s++;
 728             if (*s == '-') {
 729                 s++;
 730                 if (isSPACE(*s))
 731                     continue;
 732             }
 733             if (!*s)
 734                 break;
 735             if (!strchr("DIMUdmw", *s))
 736                 croak("Illegal switch in PERL5OPT: -%c", *s);
 737             s = moreswitches(s);
 738         }
 739     }
 740
 741     if (!scriptname)
 742         scriptname = argv[0];
 743     if (e_fp) {
 744         if (PerlIO_flush(e_fp) || PerlIO_error(e_fp) || PerlIO_close(e_fp)) {
 745 #ifndef MULTIPLICITY
 746             warn("Did you forget to compile with -DMULTIPLICITY?");
 747 #endif
 748             croak("Can't write to temp file for -e: %s", Strerror(errno));
 749         }
 750         e_fp = Nullfp;
 751         argc++,argv--;
 752         scriptname = e_tmpname;
 753     }
 754     else if (scriptname == Nullch) {
 755 #ifdef MSDOS
 756         if ( isatty(PerlIO_fileno(PerlIO_stdin())) )
 757             moreswitches("h");
 758 #endif
 759         scriptname = "-";
 760     }
 761
 762     init_perllib();
 763
 764     open_script(scriptname,dosearch,sv);
 765
 766     validate_suid(validarg, scriptname);
 767
 768     if (doextract)
 769         find_beginning();
 770
 771     main_cv = compcv = (CV*)NEWSV(1104,0);
 772     sv_upgrade((SV *)compcv, SVt_PVCV);
 773     CvUNIQUE_on(compcv);
 774
 775     comppad = newAV();
 776     av_push(comppad, Nullsv);
 777     curpad = AvARRAY(comppad);
 778     comppad_name = newAV();
 779     comppad_name_fill = 0;
 780     min_intro_pending = 0;
 781     padix = 0;
 782
 783     comppadlist = newAV();
 784     AvREAL_off(comppadlist);
 785     av_store(comppadlist, 0, (SV*)comppad_name);
 786     av_store(comppadlist, 1, (SV*)comppad);
 787     CvPADLIST(compcv) = comppadlist;
 788
 789     boot_core_UNIVERSAL();
 790     if (xsinit)
 791         (*xsinit)();    /* in case linked C routines want magical variables */
 792 #if defined(VMS) || defined(WIN32)
 793     init_os_extras();
 794 #endif
 795
 796     init_predump_symbols();
 797     if (!do_undump)
 798         init_postdump_symbols(argc,argv,env);
 799
 800     init_lexer();
 801
 802     /* now parse the script */
 803
 804     error_count = 0;
 805     if (yyparse() || error_count) {
 806         if (minus_c)
 807             croak("%s had compilation errors.\n", origfilename);
 808         else {
 809             croak("Execution of %s aborted due to compilation errors.\n",
 810                 origfilename);
 811         }
 812     }
 813     curcop->cop_line = 0;
 814     curstash = defstash;
 815     preprocess = FALSE;
 816     if (e_tmpname) {
 817         (void)UNLINK(e_tmpname);
 818         Safefree(e_tmpname);
 819         e_tmpname = Nullch;
 820     }
 821
 822     /* now that script is parsed, we can modify record separator */
 823     SvREFCNT_dec(rs);
 824     rs = SvREFCNT_inc(nrs);
 825     sv_setsv(GvSV(gv_fetchpv("/", TRUE, SVt_PV)), rs);
 826
 827     if (do_undump)
 828         my_unexec();
 829
 830     if (dowarn)
 831         gv_check(defstash);
 832
 833     LEAVE;
 834     FREETMPS;
 835
 836 #ifdef MYMALLOC
 837     if ((s=getenv("PERL_DEBUG_MSTATS")) && atoi(s) >= 2)
 838         dump_mstats("after compilation:");
 839 #endif
 840
 841     ENTER;
 842     restartop = 0;
 843     JMPENV_POP;
 844     return 0;
 845 }
 846
 847 int
 848 perl_run(sv_interp)
 849 PerlInterpreter *sv_interp;
 850 {
 851     I32 oldscope;
 852     dJMPENV;
 853     int ret;
 854
 855     if (!(curinterp = sv_interp))
 856         return 255;
 857
 858     oldscope = scopestack_ix;
 859
 860     JMPENV_PUSH(ret);
 861     switch (ret) {
 862     case 1:
 863         cxstack_ix = -1;                /* start context stack again */
 864         break;
 865     case 2:
 866         /* my_exit() was called */
 867         while (scopestack_ix > oldscope)
 868             LEAVE;
 869         FREETMPS;
 870         curstash = defstash;
 871         if (endav)
 872             call_list(oldscope, endav);
 873 #ifdef MYMALLOC
 874         if (getenv("PERL_DEBUG_MSTATS"))
 875             dump_mstats("after execution:  ");
 876 #endif
 877         JMPENV_POP;
 878         return STATUS_NATIVE_EXPORT;
 879     case 3:
 880         if (!restartop) {
 881             PerlIO_printf(PerlIO_stderr(), "panic: restartop\n");
 882             FREETMPS;
 883             JMPENV_POP;
 884             return 1;
 885         }
 886         if (curstack != mainstack) {
 887             dSP;
 888             SWITCHSTACK(curstack, mainstack);
 889         }
 890         break;
 891     }
 892
 893     DEBUG_r(PerlIO_printf(Perl_debug_log, "%s $` $& $' support.\n",
 894                     sawampersand ? "Enabling" : "Omitting"));
 895
 896     if (!restartop) {
 897         DEBUG_x(dump_all());
 898         DEBUG(PerlIO_printf(Perl_debug_log, "\nEXECUTING...\n\n"));
 899
 900         if (minus_c) {
 901             PerlIO_printf(PerlIO_stderr(), "%s syntax OK\n", origfilename);
 902             my_exit(0);
 903         }
 904         if (PERLDB_SINGLE && DBsingle)
 905            sv_setiv(DBsingle, 1);
 906     }
 907
 908     /* do it */
 909
 910     if (restartop) {
 911         op = restartop;
 912         restartop = 0;
 913         runops();
 914     }
 915     else if (main_start) {
 916         CvDEPTH(main_cv) = 1;
 917         op = main_start;
 918         runops();
 919     }
 920
 921     my_exit(0);
 922     /* NOTREACHED */
 923     return 0;
 924 }
 925
 926 SV*
 927 perl_get_sv(name, create)
 928 char* name;
 929 I32 create;
 930 {
 931     GV* gv = gv_fetchpv(name, create, SVt_PV);
 932     if (gv)
 933         return GvSV(gv);
 934     return Nullsv;
 935 }
 936
 937 AV*
 938 perl_get_av(name, create)
 939 char* name;
 940 I32 create;
 941 {
 942     GV* gv = gv_fetchpv(name, create, SVt_PVAV);
 943     if (create)
 944         return GvAVn(gv);
 945     if (gv)
 946         return GvAV(gv);
 947     return Nullav;
 948 }
 949
 950 HV*
 951 perl_get_hv(name, create)
 952 char* name;
 953 I32 create;
 954 {
 955     GV* gv = gv_fetchpv(name, create, SVt_PVHV);
 956     if (create)
 957         return GvHVn(gv);
 958     if (gv)
 959         return GvHV(gv);
 960     return Nullhv;
 961 }
 962
 963 CV*
 964 perl_get_cv(name, create)
 965 char* name;
 966 I32 create;
 967 {
 968     GV* gv = gv_fetchpv(name, create, SVt_PVCV);
 969     if (create && !GvCVu(gv))
 970         return newSUB(start_subparse(FALSE, 0),
 971                       newSVOP(OP_CONST, 0, newSVpv(name,0)),
 972                       Nullop,
 973                       Nullop);
 974     if (gv)
 975         return GvCVu(gv);
 976     return Nullcv;
 977 }
 978
 979 /* Be sure to refetch the stack pointer after calling these routines. */
 980
 981 I32
 982 perl_call_argv(subname, flags, argv)
 983 char *subname;
 984 I32 flags;              /* See G_* flags in cop.h */
 985 register char **argv;   /* null terminated arg list */
 986 {
 987     dSP;
 988
 989     PUSHMARK(sp);
 990     if (argv) {
 991         while (*argv) {
 992             XPUSHs(sv_2mortal(newSVpv(*argv,0)));
 993             argv++;
 994         }
 995         PUTBACK;
 996     }
 997     return perl_call_pv(subname, flags);
 998 }
 999
1000 I32
1001 perl_call_pv(subname, flags)
1002 char *subname;          /* name of the subroutine */
1003 I32 flags;              /* See G_* flags in cop.h */
1004 {
1005     return perl_call_sv((SV*)perl_get_cv(subname, TRUE), flags);
1006 }
1007
1008 I32
1009 perl_call_method(methname, flags)
1010 char *methname;         /* name of the subroutine */
1011 I32 flags;              /* See G_* flags in cop.h */
1012 {
1013     dSP;
1014     OP myop;
1015     if (!op)
1016         op = &myop;
1017     XPUSHs(sv_2mortal(newSVpv(methname,0)));
1018     PUTBACK;
1019     pp_method();
1020     return perl_call_sv(*stack_sp--, flags);
1021 }
1022
1023 /* May be called with any of a CV, a GV, or an SV containing the name. */
1024 I32
1025 perl_call_sv(sv, flags)
1026 SV* sv;
1027 I32 flags;              /* See G_* flags in cop.h */
1028 {
1029     LOGOP myop;         /* fake syntax tree node */
1030     SV** sp = stack_sp;
1031     I32 oldmark;
1032     I32 retval;
1033     I32 oldscope;
1034     static CV *DBcv;
1035     bool oldcatch = CATCH_GET;
1036     dJMPENV;
1037     int ret;
1038     OP* oldop = op;
1039
1040     if (flags & G_DISCARD) {
1041         ENTER;
1042         SAVETMPS;
1043     }
1044
1045     Zero(&myop, 1, LOGOP);
1046     myop.op_next = Nullop;
1047     if (!(flags & G_NOARGS))
1048         myop.op_flags |= OPf_STACKED;
1049     myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
1050                       (flags & G_ARRAY) ? OPf_WANT_LIST :
1051                       OPf_WANT_SCALAR);
1052     SAVESPTR(op);
1053     op = (OP*)&myop;
1054
1055     EXTEND(stack_sp, 1);
1056     *++stack_sp = sv;
1057     oldmark = TOPMARK;
1058     oldscope = scopestack_ix;
1059
1060     if (PERLDB_SUB && curstash != debstash
1061            /* Handle first BEGIN of -d. */
1062           && (DBcv || (DBcv = GvCV(DBsub)))
1063            /* Try harder, since this may have been a sighandler, thus
1064             * curstash may be meaningless. */
1065           && (SvTYPE(sv) != SVt_PVCV || CvSTASH((CV*)sv) != debstash))
1066         op->op_private |= OPpENTERSUB_DB;
1067
1068     if (flags & G_EVAL) {
1069         cLOGOP->op_other = op;
1070         markstack_ptr--;
1071         /* we're trying to emulate pp_entertry() here */
1072         {
1073             register CONTEXT *cx;
1074             I32 gimme = GIMME_V;
1075
1076             ENTER;
1077             SAVETMPS;
1078
1079             push_return(op->op_next);
1080             PUSHBLOCK(cx, CXt_EVAL, stack_sp);
1081             PUSHEVAL(cx, 0, 0);
1082             eval_root = op;             /* Only needed so that goto works right. */
1083
1084             in_eval = 1;
1085             if (flags & G_KEEPERR)
1086                 in_eval |= 4;
1087             else
1088                 sv_setpv(GvSV(errgv),"");
1089         }
1090         markstack_ptr++;
1091
1092         JMPENV_PUSH(ret);
1093         switch (ret) {
1094         case 0:
1095             break;
1096         case 1:
1097             STATUS_ALL_FAILURE;
1098             /* FALL THROUGH */
1099         case 2:
1100             /* my_exit() was called */
1101             curstash = defstash;
1102             FREETMPS;
1103             JMPENV_POP;
1104             if (statusvalue)
1105                 croak("Callback called exit");
1106             my_exit_jump();
1107             /* NOTREACHED */
1108         case 3:
1109             if (restartop) {
1110                 op = restartop;
1111                 restartop = 0;
1112                 break;
1113             }
1114             stack_sp = stack_base + oldmark;
1115             if (flags & G_ARRAY)
1116                 retval = 0;
1117             else {
1118                 retval = 1;
1119                 *++stack_sp = &sv_undef;
1120             }
1121             goto cleanup;
1122         }
1123     }
1124     else
1125         CATCH_SET(TRUE);
1126
1127     if (op == (OP*)&myop)
1128         op = pp_entersub();
1129     if (op)
1130         runops();
1131     retval = stack_sp - (stack_base + oldmark);
1132     if ((flags & G_EVAL) && !(flags & G_KEEPERR))
1133         sv_setpv(GvSV(errgv),"");
1134
1135   cleanup:
1136     if (flags & G_EVAL) {
1137         if (scopestack_ix > oldscope) {
1138             SV **newsp;
1139             PMOP *newpm;
1140             I32 gimme;
1141             register CONTEXT *cx;
1142             I32 optype;
1143
1144             POPBLOCK(cx,newpm);
1145             POPEVAL(cx);
1146             pop_return();
1147             curpm = newpm;
1148             LEAVE;
1149         }
1150         JMPENV_POP;
1151     }
1152     else
1153         CATCH_SET(oldcatch);
1154
1155     if (flags & G_DISCARD) {
1156         stack_sp = stack_base + oldmark;
1157         retval = 0;
1158         FREETMPS;
1159         LEAVE;
1160     }
1161     op = oldop;
1162     return retval;
1163 }
1164
1165 /* Eval a string. The G_EVAL flag is always assumed. */
1166
1167 I32
1168 perl_eval_sv(sv, flags)
1169 SV* sv;
1170 I32 flags;              /* See G_* flags in cop.h */
1171 {
1172     UNOP myop;          /* fake syntax tree node */
1173     SV** sp = stack_sp;
1174     I32 oldmark = sp - stack_base;
1175     I32 retval;
1176     I32 oldscope;
1177     dJMPENV;
1178     int ret;
1179     OP* oldop = op;
1180
1181     if (flags & G_DISCARD) {
1182         ENTER;
1183         SAVETMPS;
1184     }
1185
1186     SAVESPTR(op);
1187     op = (OP*)&myop;
1188     Zero(op, 1, UNOP);
1189     EXTEND(stack_sp, 1);
1190     *++stack_sp = sv;
1191     oldscope = scopestack_ix;
1192
1193     if (!(flags & G_NOARGS))
1194         myop.op_flags = OPf_STACKED;
1195     myop.op_next = Nullop;
1196     myop.op_type = OP_ENTEREVAL;
1197     myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
1198                       (flags & G_ARRAY) ? OPf_WANT_LIST :
1199                       OPf_WANT_SCALAR);
1200     if (flags & G_KEEPERR)
1201         myop.op_flags |= OPf_SPECIAL;
1202
1203     JMPENV_PUSH(ret);
1204     switch (ret) {
1205     case 0:
1206         break;
1207     case 1:
1208         STATUS_ALL_FAILURE;
1209         /* FALL THROUGH */
1210     case 2:
1211         /* my_exit() was called */
1212         curstash = defstash;
1213         FREETMPS;
1214         JMPENV_POP;
1215         if (statusvalue)
1216             croak("Callback called exit");
1217         my_exit_jump();
1218         /* NOTREACHED */
1219     case 3:
1220         if (restartop) {
1221             op = restartop;
1222             restartop = 0;
1223             break;
1224         }
1225         stack_sp = stack_base + oldmark;
1226         if (flags & G_ARRAY)
1227             retval = 0;
1228         else {
1229             retval = 1;
1230             *++stack_sp = &sv_undef;
1231         }
1232         goto cleanup;
1233     }
1234
1235     if (op == (OP*)&myop)
1236         op = pp_entereval();
1237     if (op)
1238         runops();
1239     retval = stack_sp - (stack_base + oldmark);
1240     if (!(flags & G_KEEPERR))
1241         sv_setpv(GvSV(errgv),"");
1242
1243   cleanup:
1244     JMPENV_POP;
1245     if (flags & G_DISCARD) {
1246         stack_sp = stack_base + oldmark;
1247         retval = 0;
1248         FREETMPS;
1249         LEAVE;
1250     }
1251     op = oldop;
1252     return retval;
1253 }
1254
1255 SV*
1256 perl_eval_pv(p, croak_on_error)
1257 char* p;
1258 I32 croak_on_error;
1259 {
1260     dSP;
1261     SV* sv = newSVpv(p, 0);
1262
1263     PUSHMARK(sp);
1264     perl_eval_sv(sv, G_SCALAR);
1265     SvREFCNT_dec(sv);
1266
1267     SPAGAIN;
1268     sv = POPs;
1269     PUTBACK;
1270
1271     if (croak_on_error && SvTRUE(GvSV(errgv)))
1272         croak(SvPVx(GvSV(errgv), na));
1273
1274     return sv;
1275 }
1276
1277 /* Require a module. */
1278
1279 void
1280 perl_require_pv(pv)
1281 char* pv;
1282 {
1283     SV* sv = sv_newmortal();
1284     sv_setpv(sv, "require '");
1285     sv_catpv(sv, pv);
1286     sv_catpv(sv, "'");
1287     perl_eval_sv(sv, G_DISCARD);
1288 }
1289
1290 void
1291 magicname(sym,name,namlen)
1292 char *sym;
1293 char *name;
1294 I32 namlen;
1295 {
1296     register GV *gv;
1297
1298     if (gv = gv_fetchpv(sym,TRUE, SVt_PV))
1299         sv_magic(GvSV(gv), (SV*)gv, 0, name, namlen);
1300 }
1301
1302 static void
1303 usage(name)             /* XXX move this out into a module ? */
1304 char *name;
1305 {
1306     /* This message really ought to be max 23 lines.
1307      * Removed -h because the user already knows that opton. Others? */
1308
1309     static char *usage[] = {
1310 "-0[octal]       specify record separator (\\0, if no argument)",
1311 "-a              autosplit mode with -n or -p (splits $_ into @F)",
1312 "-c              check syntax only (runs BEGIN and END blocks)",
1313 "-d[:debugger]   run scripts under debugger",
1314 "-D[number/list] set debugging flags (argument is a bit mask or flags)",
1315 "-e 'command'    one line of script. Several -e's allowed. Omit [programfile].",
1316 "-F/pattern/     split() pattern for autosplit (-a). The //'s are optional.",
1317 "-i[extension]   edit <> files in place (make backup if extension supplied)",
1318 "-Idirectory     specify @INC/#include directory (may be used more than once)",
1319 "-l[octal]       enable line ending processing, specifies line terminator",
1320 "-[mM][-]module.. executes `use/no module...' before executing your script.",
1321 "-n              assume 'while (<>) { ... }' loop around your script",
1322 "-p              assume loop like -n but print line also like sed",
1323 "-P              run script through C preprocessor before compilation",
1324 "-s              enable some switch parsing for switches after script name",
1325 "-S              look for the script using PATH environment variable",
1326 "-T              turn on tainting checks",
1327 "-u              dump core after parsing script",
1328 "-U              allow unsafe operations",
1329 "-v              print version number and patchlevel of perl",
1330 "-V[:variable]   print perl configuration information",
1331 "-w              TURN WARNINGS ON FOR COMPILATION OF YOUR SCRIPT. Recommended.",
1332 "-x[directory]   strip off text before #!perl line and perhaps cd to directory",
1333 "\n",
1334 NULL
1335 };
1336     char **p = usage;
1337
1338     printf("\nUsage: %s [switches] [--] [programfile] [arguments]", name);
1339     while (*p)
1340         printf("\n  %s", *p++);
1341 }
1342
1343 /* This routine handles any switches that can be given during run */
1344
1345 char *
1346 moreswitches(s)
1347 char *s;
1348 {
1349     I32 numlen;
1350     U32 rschar;
1351
1352     switch (*s) {
1353     case '0':
1354         rschar = scan_oct(s, 4, &numlen);
1355         SvREFCNT_dec(nrs);
1356         if (rschar & ~((U8)~0))
1357             nrs = &sv_undef;
1358         else if (!rschar && numlen >= 2)
1359             nrs = newSVpv("", 0);
1360         else {
1361             char ch = rschar;
1362             nrs = newSVpv(&ch, 1);
1363         }
1364         return s + numlen;
1365     case 'F':
1366         minus_F = TRUE;
1367         splitstr = savepv(s + 1);
1368         s += strlen(s);
1369         return s;
1370     case 'a':
1371         minus_a = TRUE;
1372         s++;
1373         return s;
1374     case 'c':
1375         minus_c = TRUE;
1376         s++;
1377         return s;
1378     case 'd':
1379         forbid_setid("-d");
1380         s++;
1381         if (*s == ':' || *s == '=')  {
1382             my_setenv("PERL5DB", form("use Devel::%s;", ++s));
1383             s += strlen(s);
1384         }
1385         if (!perldb) {
1386             perldb = PERLDB_ALL;
1387             init_debugger();
1388         }
1389         return s;
1390     case 'D':
1391 #ifdef DEBUGGING
1392         forbid_setid("-D");
1393         if (isALPHA(s[1])) {
1394             static char debopts[] = "psltocPmfrxuLHXD";
1395             char *d;
1396
1397             for (s++; *s && (d = strchr(debopts,*s)); s++)
1398                 debug |= 1 << (d - debopts);
1399         }
1400         else {
1401             debug = atoi(s+1);
1402             for (s++; isDIGIT(*s); s++) ;
1403         }
1404         debug |= 0x80000000;
1405 #else
1406         warn("Recompile perl with -DDEBUGGING to use -D switch\n");
1407         for (s++; isALNUM(*s); s++) ;
1408 #endif
1409         /*SUPPRESS 530*/
1410         return s;
1411     case 'h':
1412         usage(origargv[0]);
1413         exit(0);
1414     case 'i':
1415         if (inplace)
1416             Safefree(inplace);
1417         inplace = savepv(s+1);
1418         /*SUPPRESS 530*/
1419         for (s = inplace; *s && !isSPACE(*s); s++) ;
1420         if (*s)
1421             *s++ = '\0';
1422         return s;
1423     case 'I':   /* -I handled both here and in parse_perl() */
1424         forbid_setid("-I");
1425         ++s;
1426         while (*s && isSPACE(*s))
1427             ++s;
1428         if (*s) {
1429             char *e, *p;
1430             for (e = s; *e && !isSPACE(*e); e++) ;
1431             p = savepvn(s, e-s);
1432             incpush(p, TRUE);
1433             Safefree(p);
1434             s = e;
1435         }
1436         else
1437             croak("No space allowed after -I");
1438         return s;
1439     case 'l':
1440         minus_l = TRUE;
1441         s++;
1442         if (ors)
1443             Safefree(ors);
1444         if (isDIGIT(*s)) {
1445             ors = savepv("\n");
1446             orslen = 1;
1447             *ors = scan_oct(s, 3 + (*s == '0'), &numlen);
1448             s += numlen;
1449         }
1450         else {
1451             if (RsPARA(nrs)) {
1452                 ors = "\n\n";
1453                 orslen = 2;
1454             }
1455             else
1456                 ors = SvPV(nrs, orslen);
1457             ors = savepvn(ors, orslen);
1458         }
1459         return s;
1460     case 'M':
1461         forbid_setid("-M");     /* XXX ? */
1462         /* FALL THROUGH */
1463     case 'm':
1464         forbid_setid("-m");     /* XXX ? */
1465         if (*++s) {
1466             char *start;
1467             char *use = "use ";
1468             /* -M-foo == 'no foo'       */
1469             if (*s == '-') { use = "no "; ++s; }
1470             Sv = newSVpv(use,0);
1471             start = s;
1472             /* We allow -M'Module qw(Foo Bar)'  */
1473             while(isALNUM(*s) || *s==':') ++s;
1474             if (*s != '=') {
1475                 sv_catpv(Sv, start);
1476                 if (*(start-1) == 'm') {
1477                     if (*s != '\0')
1478                         croak("Can't use '%c' after -mname", *s);
1479                     sv_catpv( Sv, " ()");
1480                 }
1481             } else {
1482                 sv_catpvn(Sv, start, s-start);
1483                 sv_catpv(Sv, " split(/,/,q{");
1484                 sv_catpv(Sv, ++s);
1485                 sv_catpv(Sv,    "})");
1486             }
1487             s += strlen(s);
1488             if (preambleav == NULL)
1489                 preambleav = newAV();
1490             av_push(preambleav, Sv);
1491         }
1492         else
1493             croak("No space allowed after -%c", *(s-1));
1494         return s;
1495     case 'n':
1496         minus_n = TRUE;
1497         s++;
1498         return s;
1499     case 'p':
1500         minus_p = TRUE;
1501         s++;
1502         return s;
1503     case 's':
1504         forbid_setid("-s");
1505         doswitches = TRUE;
1506         s++;
1507         return s;
1508     case 'T':
1509         if (!tainting)
1510             croak("Too late for \"-T\" option");
1511         s++;
1512         return s;
1513     case 'u':
1514         do_undump = TRUE;
1515         s++;
1516         return s;
1517     case 'U':
1518         unsafe = TRUE;
1519         s++;
1520         return s;
1521     case 'v':
1522 #if defined(SUBVERSION) && SUBVERSION > 0
1523         printf("\nThis is perl, version 5.%03d_%02d built for %s",
1524             PATCHLEVEL, SUBVERSION, ARCHNAME);
1525 #else
1526         printf("\nThis is perl, version %s built for %s",
1527                 patchlevel, ARCHNAME);
1528 #endif
1529 #if defined(LOCAL_PATCH_COUNT)
1530         if (LOCAL_PATCH_COUNT > 0)
1531             printf("\n(with %d registered patch%s, see perl -V for more detail)",
1532                 LOCAL_PATCH_COUNT, (LOCAL_PATCH_COUNT!=1) ? "es" : "");
1533 #endif
1534
1535         printf("\n\nCopyright 1987-1997, Larry Wall\n");
1536 #ifdef MSDOS
1537         printf("\nMS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n");
1538 #endif
1539 #ifdef DJGPP
1540         printf("djgpp v2 port (jpl5003c) by Hirofumi Watanabe, 1996\n");
1541 #endif
1542 #ifdef OS2
1543         printf("\n\nOS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n"
1544             "Version 5 port Copyright (c) 1994-1997, Andreas Kaiser, Ilya Zakharevich\n");
1545 #endif
1546 #ifdef atarist
1547         printf("atariST series port, ++jrb  bammi@cadence.com\n");
1548 #endif
1549         printf("\n\
1550 Perl may be copied only under the terms of either the Artistic License or the\n\
1551 GNU General Public License, which may be found in the Perl 5.0 source kit.\n\n");
1552         exit(0);
1553     case 'w':
1554         dowarn = TRUE;
1555         s++;
1556         return s;
1557     case '*':
1558     case ' ':
1559         if (s[1] == '-')        /* Additional switches on #! line. */
1560             return s+2;
1561         break;
1562     case '-':
1563     case 0:
1564     case '\n':
1565     case '\t':
1566         break;
1567 #ifdef ALTERNATE_SHEBANG
1568     case 'S':                   /* OS/2 needs -S on "extproc" line. */
1569         break;
1570 #endif
1571     case 'P':
1572         if (preprocess)
1573             return s+1;
1574         /* FALL THROUGH */
1575     default:
1576         croak("Can't emulate -%.1s on #! line",s);
1577     }
1578     return Nullch;
1579 }
1580
1581 /* compliments of Tom Christiansen */
1582
1583 /* unexec() can be found in the Gnu emacs distribution */
1584
1585 void
1586 my_unexec()
1587 {
1588 #ifdef UNEXEC
1589     SV*    prog;
1590     SV*    file;
1591     int    status;
1592     extern int etext;
1593
1594     prog = newSVpv(BIN_EXP);
1595     sv_catpv(prog, "/perl");
1596     file = newSVpv(origfilename);
1597     sv_catpv(file, ".perldump");
1598
1599     status = unexec(SvPVX(file), SvPVX(prog), &etext, sbrk(0), 0);
1600     if (status)
1601         PerlIO_printf(PerlIO_stderr(), "unexec of %s into %s failed!\n",
1602                       SvPVX(prog), SvPVX(file));
1603     exit(status);
1604 #else
1605 #  ifdef VMS
1606 #    include <lib$routines.h>
1607      lib$signal(SS$_DEBUG);  /* ssdef.h #included from vmsish.h */
1608 #  else
1609     ABORT();            /* for use with undump */
1610 #  endif
1611 #endif
1612 }
1613
1614 static void
1615 init_main_stash()
1616 {
1617     GV *gv;
1618
1619     /* Note that strtab is a rather special HV.  Assumptions are made
1620        about not iterating on it, and not adding tie magic to it.
1621        It is properly deallocated in perl_destruct() */
1622     strtab = newHV();
1623     HvSHAREKEYS_off(strtab);                    /* mandatory */
1624     Newz(506,((XPVHV*)SvANY(strtab))->xhv_array,
1625          sizeof(HE*) * (((XPVHV*)SvANY(strtab))->xhv_max + 1), char);
1626
1627     curstash = defstash = newHV();
1628     curstname = newSVpv("main",4);
1629     gv = gv_fetchpv("main::",TRUE, SVt_PVHV);
1630     SvREFCNT_dec(GvHV(gv));
1631     GvHV(gv) = (HV*)SvREFCNT_inc(defstash);
1632     SvREADONLY_on(gv);
1633     HvNAME(defstash) = savepv("main");
1634     incgv = gv_HVadd(gv_AVadd(gv_fetchpv("INC",TRUE, SVt_PVAV)));
1635     GvMULTI_on(incgv);
1636     defgv = gv_fetchpv("_",TRUE, SVt_PVAV);
1637     errgv = gv_HVadd(gv_fetchpv("@", TRUE, SVt_PV));
1638     GvMULTI_on(errgv);
1639     (void)form("%240s","");     /* Preallocate temp - for immediate signals. */
1640     sv_grow(GvSV(errgv), 240);  /* Preallocate - for immediate signals. */
1641     sv_setpvn(GvSV(errgv), "", 0);
1642     curstash = defstash;
1643     compiling.cop_stash = defstash;
1644     debstash = GvHV(gv_fetchpv("DB::", GV_ADDMULTI, SVt_PVHV));
1645     /* We must init $/ before switches are processed. */
1646     sv_setpvn(GvSV(gv_fetchpv("/", TRUE, SVt_PV)), "\n", 1);
1647 }
1648
1649 #ifdef CAN_PROTOTYPE
1650 static void
1651 open_script(char *scriptname, bool dosearch, SV *sv)
1652 #else
1653 static void
1654 open_script(scriptname,dosearch,sv)
1655 char *scriptname;
1656 bool dosearch;
1657 SV *sv;
1658 #endif
1659 {
1660     char *xfound = Nullch;
1661     char *xfailed = Nullch;
1662     register char *s;
1663     I32 len;
1664     int retval;
1665 #if defined(DOSISH) && !defined(OS2) && !defined(atarist)
1666 #  define SEARCH_EXTS ".bat", ".cmd", NULL
1667 #  define MAX_EXT_LEN 4
1668 #endif
1669 #ifdef OS2
1670 #  define SEARCH_EXTS ".cmd", ".btm", ".bat", ".pl", NULL
1671 #  define MAX_EXT_LEN 4
1672 #endif
1673 #ifdef VMS
1674 #  define SEARCH_EXTS ".pl", ".com", NULL
1675 #  define MAX_EXT_LEN 4
1676 #endif
1677     /* additional extensions to try in each dir if scriptname not found */
1678 #ifdef SEARCH_EXTS
1679     char *ext[] = { SEARCH_EXTS };
1680     int extidx = 0, i = 0;
1681     char *curext = Nullch;
1682 #else
1683 #  define MAX_EXT_LEN 0
1684 #endif
1685
1686     /*
1687      * If dosearch is true and if scriptname does not contain path
1688      * delimiters, search the PATH for scriptname.
1689      *
1690      * If SEARCH_EXTS is also defined, will look for each
1691      * scriptname{SEARCH_EXTS} whenever scriptname is not found
1692      * while searching the PATH.
1693      *
1694      * Assuming SEARCH_EXTS is C<".foo",".bar",NULL>, PATH search
1695      * proceeds as follows:
1696      *   If DOSISH:
1697      *     + look for ./scriptname{,.foo,.bar}
1698      *     + search the PATH for scriptname{,.foo,.bar}
1699      *
1700      *   If !DOSISH:
1701      *     + look *only* in the PATH for scriptname{,.foo,.bar} (note
1702      *       this will not look in '.' if it's not in the PATH)
1703      */
1704
1705 #ifdef VMS
1706     if (dosearch) {
1707         int hasdir, idx = 0, deftypes = 1;
1708         bool seen_dot = 1;
1709
1710         hasdir = (strpbrk(scriptname,":[</") != Nullch) ;
1711         /* The first time through, just add SEARCH_EXTS to whatever we
1712          * already have, so we can check for default file types. */
1713         while (deftypes ||
1714                (!hasdir && my_trnlnm("DCL$PATH",tokenbuf,idx++)) )
1715         {
1716             if (deftypes) {
1717                 deftypes = 0;
1718                 *tokenbuf = '\0';
1719             }
1720             if ((strlen(tokenbuf) + strlen(scriptname)
1721                  + MAX_EXT_LEN) >= sizeof tokenbuf)
1722                 continue;       /* don't search dir with too-long name */
1723             strcat(tokenbuf, scriptname);
1724 #else  /* !VMS */
1725
1726 #ifdef DOSISH
1727     if (strEQ(scriptname, "-"))
1728         dosearch = 0;
1729     if (dosearch) {             /* Look in '.' first. */
1730         char *cur = scriptname;
1731 #ifdef SEARCH_EXTS
1732         if ((curext = strrchr(scriptname,'.'))) /* possible current ext */
1733             while (ext[i])
1734                 if (strEQ(ext[i++],curext)) {
1735                     extidx = -1;                /* already has an ext */
1736                     break;
1737                 }
1738         do {
1739 #endif
1740             DEBUG_p(PerlIO_printf(Perl_debug_log,
1741                                   "Looking for %s\n",cur));
1742             if (Stat(cur,&statbuf) >= 0) {
1743                 dosearch = 0;
1744                 scriptname = cur;
1745 #ifdef SEARCH_EXTS
1746                 break;
1747 #endif
1748             }
1749 #ifdef SEARCH_EXTS
1750             if (cur == scriptname) {
1751                 len = strlen(scriptname);
1752                 if (len+MAX_EXT_LEN+1 >= sizeof(tokenbuf))
1753                     break;
1754                 cur = strcpy(tokenbuf, scriptname);
1755             }
1756         } while (extidx >= 0 && ext[extidx]     /* try an extension? */
1757                  && strcpy(tokenbuf+len, ext[extidx++]));
1758 #endif
1759     }
1760 #endif
1761
1762     if (dosearch && !strchr(scriptname, '/')
1763 #ifdef DOSISH
1764                  && !strchr(scriptname, '\\')
1765 #endif
1766                  && (s = getenv("PATH"))) {
1767         bool seen_dot = 0;
1768
1769         bufend = s + strlen(s);
1770         while (s < bufend) {
1771 #if defined(atarist) || defined(DOSISH)
1772             for (len = 0; *s
1773 #  ifdef atarist
1774                     && *s != ','
1775 #  endif
1776                     && *s != ';'; len++, s++) {
1777                 if (len < sizeof tokenbuf)
1778                     tokenbuf[len] = *s;
1779             }
1780             if (len < sizeof tokenbuf)
1781                 tokenbuf[len] = '\0';
1782 #else  /* ! (atarist || DOSISH) */
1783             s = delimcpy(tokenbuf, tokenbuf + sizeof tokenbuf, s, bufend,
1784                         ':',
1785                         &len);
1786 #endif /* ! (atarist || DOSISH) */
1787             if (s < bufend)
1788                 s++;
1789             if (len + 1 + strlen(scriptname) + MAX_EXT_LEN >= sizeof tokenbuf)
1790                 continue;       /* don't search dir with too-long name */
1791             if (len
1792 #if defined(atarist) || defined(DOSISH)
1793                 && tokenbuf[len - 1] != '/'
1794                 && tokenbuf[len - 1] != '\\'
1795 #endif
1796                )
1797                 tokenbuf[len++] = '/';
1798             if (len == 2 && tokenbuf[0] == '.')
1799                 seen_dot = 1;
1800             (void)strcpy(tokenbuf + len, scriptname);
1801 #endif  /* !VMS */
1802
1803 #ifdef SEARCH_EXTS
1804             len = strlen(tokenbuf);
1805             if (extidx > 0)     /* reset after previous loop */
1806                 extidx = 0;
1807             do {
1808 #endif
1809                 DEBUG_p(PerlIO_printf(Perl_debug_log, "Looking for %s\n",tokenbuf));
1810                 retval = Stat(tokenbuf,&statbuf);
1811 #ifdef SEARCH_EXTS
1812             } while (  retval < 0               /* not there */
1813                     && extidx>=0 && ext[extidx] /* try an extension? */
1814                     && strcpy(tokenbuf+len, ext[extidx++])
1815                 );
1816 #endif
1817             if (retval < 0)
1818                 continue;
1819             if (S_ISREG(statbuf.st_mode)
1820                 && cando(S_IRUSR,TRUE,&statbuf)
1821 #ifndef DOSISH
1822                 && cando(S_IXUSR,TRUE,&statbuf)
1823 #endif
1824                 )
1825             {
1826                 xfound = tokenbuf;              /* bingo! */
1827                 break;
1828             }
1829             if (!xfailed)
1830                 xfailed = savepv(tokenbuf);
1831         }
1832 #ifndef DOSISH
1833         if (!xfound && !seen_dot && !xfailed && (Stat(scriptname,&statbuf) < 0))
1834 #endif
1835             seen_dot = 1;                       /* Disable message. */
1836         if (!xfound)
1837             croak("Can't %s %s%s%s",
1838                   (xfailed ? "execute" : "find"),
1839                   (xfailed ? xfailed : scriptname),
1840                   (xfailed ? "" : " on PATH"),
1841                   (xfailed || seen_dot) ? "" : ", '.' not in PATH");
1842         if (xfailed)
1843             Safefree(xfailed);
1844         scriptname = xfound;
1845     }
1846
1847     if (strnEQ(scriptname, "/dev/fd/", 8) && isDIGIT(scriptname[8]) ) {
1848         char *s = scriptname + 8;
1849         fdscript = atoi(s);
1850         while (isDIGIT(*s))
1851             s++;
1852         if (*s)
1853             scriptname = s + 1;
1854     }
1855     else
1856         fdscript = -1;
1857     origfilename = savepv(e_tmpname ? "-e" : scriptname);
1858     curcop->cop_filegv = gv_fetchfile(origfilename);
1859     if (strEQ(origfilename,"-"))
1860         scriptname = "";
1861     if (fdscript >= 0) {
1862         rsfp = PerlIO_fdopen(fdscript,"r");
1863 #if defined(HAS_FCNTL) && defined(F_SETFD)
1864         if (rsfp)
1865             fcntl(PerlIO_fileno(rsfp),F_SETFD,1);  /* ensure close-on-exec */
1866 #endif
1867     }
1868     else if (preprocess) {
1869         char *cpp_cfg = CPPSTDIN;
1870         SV *cpp = NEWSV(0,0);
1871         SV *cmd = NEWSV(0,0);
1872
1873         if (strEQ(cpp_cfg, "cppstdin"))
1874             sv_catpvf(cpp, "%s/", BIN_EXP);
1875         sv_catpv(cpp, cpp_cfg);
1876
1877         sv_catpv(sv,"-I");
1878         sv_catpv(sv,PRIVLIB_EXP);
1879
1880 #ifdef MSDOS
1881         sv_setpvf(cmd, "\
1882 sed %s -e \"/^[^#]/b\" \
1883  -e \"/^#[      ]*include[      ]/b\" \
1884  -e \"/^#[      ]*define[       ]/b\" \
1885  -e \"/^#[      ]*if[   ]/b\" \
1886  -e \"/^#[      ]*ifdef[        ]/b\" \
1887  -e \"/^#[      ]*ifndef[       ]/b\" \
1888  -e \"/^#[      ]*else/b\" \
1889  -e \"/^#[      ]*elif[         ]/b\" \
1890  -e \"/^#[      ]*undef[        ]/b\" \
1891  -e \"/^#[      ]*endif/b\" \
1892  -e \"s/^#.*//\" \
1893  %s | %_ -C %_ %s",
1894           (doextract ? "-e \"1,/^#/d\n\"" : ""),
1895 #else
1896         sv_setpvf(cmd, "\
1897 %s %s -e '/^[^#]/b' \
1898  -e '/^#[       ]*include[      ]/b' \
1899  -e '/^#[       ]*define[       ]/b' \
1900  -e '/^#[       ]*if[   ]/b' \
1901  -e '/^#[       ]*ifdef[        ]/b' \
1902  -e '/^#[       ]*ifndef[       ]/b' \
1903  -e '/^#[       ]*else/b' \
1904  -e '/^#[       ]*elif[         ]/b' \
1905  -e '/^#[       ]*undef[        ]/b' \
1906  -e '/^#[       ]*endif/b' \
1907  -e 's/^[       ]*#.*//' \
1908  %s | %_ -C %_ %s",
1909 #ifdef LOC_SED
1910           LOC_SED,
1911 #else
1912           "sed",
1913 #endif
1914           (doextract ? "-e '1,/^#/d\n'" : ""),
1915 #endif
1916           scriptname, cpp, sv, CPPMINUS);
1917         doextract = FALSE;
1918 #ifdef IAMSUID                          /* actually, this is caught earlier */
1919         if (euid != uid && !euid) {     /* if running suidperl */
1920 #ifdef HAS_SETEUID
1921             (void)seteuid(uid);         /* musn't stay setuid root */
1922 #else
1923 #ifdef HAS_SETREUID
1924             (void)setreuid((Uid_t)-1, uid);
1925 #else
1926 #ifdef HAS_SETRESUID
1927             (void)setresuid((Uid_t)-1, uid, (Uid_t)-1);
1928 #else
1929             setuid(uid);
1930 #endif
1931 #endif
1932 #endif
1933             if (geteuid() != uid)
1934                 croak("Can't do seteuid!\n");
1935         }
1936 #endif /* IAMSUID */
1937         rsfp = my_popen(SvPVX(cmd), "r");
1938         SvREFCNT_dec(cmd);
1939         SvREFCNT_dec(cpp);
1940     }
1941     else if (!*scriptname) {
1942         forbid_setid("program input from stdin");
1943         rsfp = PerlIO_stdin();
1944     }
1945     else {
1946         rsfp = PerlIO_open(scriptname,"r");
1947 #if defined(HAS_FCNTL) && defined(F_SETFD)
1948         if (rsfp)
1949             fcntl(PerlIO_fileno(rsfp),F_SETFD,1);  /* ensure close-on-exec */
1950 #endif
1951     }
1952     if (e_tmpname) {
1953         e_fp = rsfp;
1954     }
1955     if (!rsfp) {
1956 #ifdef DOSUID
1957 #ifndef IAMSUID         /* in case script is not readable before setuid */
1958         if (euid && Stat(SvPVX(GvSV(curcop->cop_filegv)),&statbuf) >= 0 &&
1959           statbuf.st_mode & (S_ISUID|S_ISGID)) {
1960             /* try again */
1961             execv(form("%s/sperl%s", BIN_EXP, patchlevel), origargv);
1962             croak("Can't do setuid\n");
1963         }
1964 #endif
1965 #endif
1966         croak("Can't open perl script \"%s\": %s\n",
1967           SvPVX(GvSV(curcop->cop_filegv)), Strerror(errno));
1968     }
1969 }
1970
1971 static void
1972 validate_suid(validarg, scriptname)
1973 char *validarg;
1974 char *scriptname;
1975 {
1976     int which;
1977
1978     /* do we need to emulate setuid on scripts? */
1979
1980     /* This code is for those BSD systems that have setuid #! scripts disabled
1981      * in the kernel because of a security problem.  Merely defining DOSUID
1982      * in perl will not fix that problem, but if you have disabled setuid
1983      * scripts in the kernel, this will attempt to emulate setuid and setgid
1984      * on scripts that have those now-otherwise-useless bits set.  The setuid
1985      * root version must be called suidperl or sperlN.NNN.  If regular perl
1986      * discovers that it has opened a setuid script, it calls suidperl with
1987      * the same argv that it had.  If suidperl finds that the script it has
1988      * just opened is NOT setuid root, it sets the effective uid back to the
1989      * uid.  We don't just make perl setuid root because that loses the
1990      * effective uid we had before invoking perl, if it was different from the
1991      * uid.
1992      *
1993      * DOSUID must be defined in both perl and suidperl, and IAMSUID must
1994      * be defined in suidperl only.  suidperl must be setuid root.  The
1995      * Configure script will set this up for you if you want it.
1996      */
1997
1998 #ifdef DOSUID
1999     char *s, *s2;
2000
2001     if (Fstat(PerlIO_fileno(rsfp),&statbuf) < 0)        /* normal stat is insecure */
2002         croak("Can't stat script \"%s\"",origfilename);
2003     if (fdscript < 0 && statbuf.st_mode & (S_ISUID|S_ISGID)) {
2004         I32 len;
2005
2006 #ifdef IAMSUID
2007 #ifndef HAS_SETREUID
2008         /* On this access check to make sure the directories are readable,
2009          * there is actually a small window that the user could use to make
2010          * filename point to an accessible directory.  So there is a faint
2011          * chance that someone could execute a setuid script down in a
2012          * non-accessible directory.  I don't know what to do about that.
2013          * But I don't think it's too important.  The manual lies when
2014          * it says access() is useful in setuid programs.
2015          */
2016         if (access(SvPVX(GvSV(curcop->cop_filegv)),1))  /*double check*/
2017             croak("Permission denied");
2018 #else
2019         /* If we can swap euid and uid, then we can determine access rights
2020          * with a simple stat of the file, and then compare device and
2021          * inode to make sure we did stat() on the same file we opened.
2022          * Then we just have to make sure he or she can execute it.
2023          */
2024         {
2025             struct stat tmpstatbuf;
2026
2027             if (
2028 #ifdef HAS_SETREUID
2029                 setreuid(euid,uid) < 0
2030 #else
2031 # if HAS_SETRESUID
2032                 setresuid(euid,uid,(Uid_t)-1) < 0
2033 # endif
2034 #endif
2035                 || getuid() != euid || geteuid() != uid)
2036                 croak("Can't swap uid and euid");       /* really paranoid */
2037             if (Stat(SvPVX(GvSV(curcop->cop_filegv)),&tmpstatbuf) < 0)
2038                 croak("Permission denied");     /* testing full pathname here */
2039             if (tmpstatbuf.st_dev != statbuf.st_dev ||
2040                 tmpstatbuf.st_ino != statbuf.st_ino) {
2041                 (void)PerlIO_close(rsfp);
2042                 if (rsfp = my_popen("/bin/mail root","w")) {    /* heh, heh */
2043                     PerlIO_printf(rsfp,
2044 "User %ld tried to run dev %ld ino %ld in place of dev %ld ino %ld!\n\
2045 (Filename of set-id script was %s, uid %ld gid %ld.)\n\nSincerely,\nperl\n",
2046                         (long)uid,(long)tmpstatbuf.st_dev, (long)tmpstatbuf.st_ino,
2047                         (long)statbuf.st_dev, (long)statbuf.st_ino,
2048                         SvPVX(GvSV(curcop->cop_filegv)),
2049                         (long)statbuf.st_uid, (long)statbuf.st_gid);
2050                     (void)my_pclose(rsfp);
2051                 }
2052                 croak("Permission denied\n");
2053             }
2054             if (
2055 #ifdef HAS_SETREUID
2056               setreuid(uid,euid) < 0
2057 #else
2058 # if defined(HAS_SETRESUID)
2059               setresuid(uid,euid,(Uid_t)-1) < 0
2060 # endif
2061 #endif
2062               || getuid() != uid || geteuid() != euid)
2063                 croak("Can't reswap uid and euid");
2064             if (!cando(S_IXUSR,FALSE,&statbuf))         /* can real uid exec? */
2065                 croak("Permission denied\n");
2066         }
2067 #endif /* HAS_SETREUID */
2068 #endif /* IAMSUID */
2069
2070         if (!S_ISREG(statbuf.st_mode))
2071             croak("Permission denied");
2072         if (statbuf.st_mode & S_IWOTH)
2073             croak("Setuid/gid script is writable by world");
2074         doswitches = FALSE;             /* -s is insecure in suid */
2075         curcop->cop_line++;
2076         if (sv_gets(linestr, rsfp, 0) == Nullch ||
2077           strnNE(SvPV(linestr,na),"#!",2) )     /* required even on Sys V */
2078             croak("No #! line");
2079         s = SvPV(linestr,na)+2;
2080         if (*s == ' ') s++;
2081         while (!isSPACE(*s)) s++;
2082         for (s2 = s;  (s2 > SvPV(linestr,na)+2 &&
2083                        (isDIGIT(s2[-1]) || strchr("._-", s2[-1])));  s2--) ;
2084         if (strnNE(s2-4,"perl",4) && strnNE(s-9,"perl",4))  /* sanity check */
2085             croak("Not a perl script");
2086         while (*s == ' ' || *s == '\t') s++;
2087         /*
2088          * #! arg must be what we saw above.  They can invoke it by
2089          * mentioning suidperl explicitly, but they may not add any strange
2090          * arguments beyond what #! says if they do invoke suidperl that way.
2091          */
2092         len = strlen(validarg);
2093         if (strEQ(validarg," PHOOEY ") ||
2094             strnNE(s,validarg,len) || !isSPACE(s[len]))
2095             croak("Args must match #! line");
2096
2097 #ifndef IAMSUID
2098         if (euid != uid && (statbuf.st_mode & S_ISUID) &&
2099             euid == statbuf.st_uid)
2100             if (!do_undump)
2101                 croak("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
2102 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
2103 #endif /* IAMSUID */
2104
2105         if (euid) {     /* oops, we're not the setuid root perl */
2106             (void)PerlIO_close(rsfp);
2107 #ifndef IAMSUID
2108             /* try again */
2109             execv(form("%s/sperl%s", BIN_EXP, patchlevel), origargv);
2110 #endif
2111             croak("Can't do setuid\n");
2112         }
2113
2114         if (statbuf.st_mode & S_ISGID && statbuf.st_gid != egid) {
2115 #ifdef HAS_SETEGID
2116             (void)setegid(statbuf.st_gid);
2117 #else
2118 #ifdef HAS_SETREGID
2119            (void)setregid((Gid_t)-1,statbuf.st_gid);
2120 #else
2121 #ifdef HAS_SETRESGID
2122            (void)setresgid((Gid_t)-1,statbuf.st_gid,(Gid_t)-1);
2123 #else
2124             setgid(statbuf.st_gid);
2125 #endif
2126 #endif
2127 #endif
2128             if (getegid() != statbuf.st_gid)
2129                 croak("Can't do setegid!\n");
2130         }
2131         if (statbuf.st_mode & S_ISUID) {
2132             if (statbuf.st_uid != euid)
2133 #ifdef HAS_SETEUID
2134                 (void)seteuid(statbuf.st_uid);  /* all that for this */
2135 #else
2136 #ifdef HAS_SETREUID
2137                 (void)setreuid((Uid_t)-1,statbuf.st_uid);
2138 #else
2139 #ifdef HAS_SETRESUID
2140                 (void)setresuid((Uid_t)-1,statbuf.st_uid,(Uid_t)-1);
2141 #else
2142                 setuid(statbuf.st_uid);
2143 #endif
2144 #endif
2145 #endif
2146             if (geteuid() != statbuf.st_uid)
2147                 croak("Can't do seteuid!\n");
2148         }
2149         else if (uid) {                 /* oops, mustn't run as root */
2150 #ifdef HAS_SETEUID
2151           (void)seteuid((Uid_t)uid);
2152 #else
2153 #ifdef HAS_SETREUID
2154           (void)setreuid((Uid_t)-1,(Uid_t)uid);
2155 #else
2156 #ifdef HAS_SETRESUID
2157           (void)setresuid((Uid_t)-1,(Uid_t)uid,(Uid_t)-1);
2158 #else
2159           setuid((Uid_t)uid);
2160 #endif
2161 #endif
2162 #endif
2163             if (geteuid() != uid)
2164                 croak("Can't do seteuid!\n");
2165         }
2166         init_ids();
2167         if (!cando(S_IXUSR,TRUE,&statbuf))
2168             croak("Permission denied\n");       /* they can't do this */
2169     }
2170 #ifdef IAMSUID
2171     else if (preprocess)
2172         croak("-P not allowed for setuid/setgid script\n");
2173     else if (fdscript >= 0)
2174         croak("fd script not allowed in suidperl\n");
2175     else
2176         croak("Script is not setuid/setgid in suidperl\n");
2177
2178     /* We absolutely must clear out any saved ids here, so we */
2179     /* exec the real perl, substituting fd script for scriptname. */
2180     /* (We pass script name as "subdir" of fd, which perl will grok.) */
2181     PerlIO_rewind(rsfp);
2182     lseek(PerlIO_fileno(rsfp),(Off_t)0,0);  /* just in case rewind didn't */
2183     for (which = 1; origargv[which] && origargv[which] != scriptname; which++) ;
2184     if (!origargv[which])
2185         croak("Permission denied");
2186     origargv[which] = savepv(form("/dev/fd/%d/%s",
2187                                   PerlIO_fileno(rsfp), origargv[which]));
2188 #if defined(HAS_FCNTL) && defined(F_SETFD)
2189     fcntl(PerlIO_fileno(rsfp),F_SETFD,0);       /* ensure no close-on-exec */
2190 #endif
2191     execv(form("%s/perl%s", BIN_EXP, patchlevel), origargv);    /* try again */
2192     croak("Can't do setuid\n");
2193 #endif /* IAMSUID */
2194 #else /* !DOSUID */
2195     if (euid != uid || egid != gid) {   /* (suidperl doesn't exist, in fact) */
2196 #ifndef SETUID_SCRIPTS_ARE_SECURE_NOW
2197         Fstat(PerlIO_fileno(rsfp),&statbuf);    /* may be either wrapped or real suid */
2198         if ((euid != uid && euid == statbuf.st_uid && statbuf.st_mode & S_ISUID)
2199             ||
2200             (egid != gid && egid == statbuf.st_gid && statbuf.st_mode & S_ISGID)
2201            )
2202             if (!do_undump)
2203                 croak("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
2204 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
2205 #endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
2206         /* not set-id, must be wrapped */
2207     }
2208 #endif /* DOSUID */
2209 }
2210
2211 static void
2212 find_beginning()
2213 {
2214     register char *s, *s2;
2215
2216     /* skip forward in input to the real script? */
2217
2218     forbid_setid("-x");
2219     while (doextract) {
2220         if ((s = sv_gets(linestr, rsfp, 0)) == Nullch)
2221             croak("No Perl script found in input\n");
2222         if (*s == '#' && s[1] == '!' && (s = instr(s,"perl"))) {
2223             PerlIO_ungetc(rsfp, '\n');          /* to keep line count right */
2224             doextract = FALSE;
2225             while (*s && !(isSPACE (*s) || *s == '#')) s++;
2226             s2 = s;
2227             while (*s == ' ' || *s == '\t') s++;
2228             if (*s++ == '-') {
2229                 while (isDIGIT(s2[-1]) || strchr("-._", s2[-1])) s2--;
2230                 if (strnEQ(s2-4,"perl",4))
2231                     /*SUPPRESS 530*/
2232                     while (s = moreswitches(s)) ;
2233             }
2234             if (cddir && chdir(cddir) < 0)
2235                 croak("Can't chdir to %s",cddir);
2236         }
2237     }
2238 }
2239
2240 static void
2241 init_ids()
2242 {
2243     uid = (int)getuid();
2244     euid = (int)geteuid();
2245     gid = (int)getgid();
2246     egid = (int)getegid();
2247 #ifdef VMS
2248     uid |= gid << 16;
2249     euid |= egid << 16;
2250 #endif
2251     tainting |= (uid && (euid != uid || egid != gid));
2252 }
2253
2254 static void
2255 forbid_setid(s)
2256 char *s;
2257 {
2258     if (euid != uid)
2259         croak("No %s allowed while running setuid", s);
2260     if (egid != gid)
2261         croak("No %s allowed while running setgid", s);
2262 }
2263
2264 static void
2265 init_debugger()
2266 {
2267     curstash = debstash;
2268     dbargs = GvAV(gv_AVadd((gv_fetchpv("args", GV_ADDMULTI, SVt_PVAV))));
2269     AvREAL_off(dbargs);
2270     DBgv = gv_fetchpv("DB", GV_ADDMULTI, SVt_PVGV);
2271     DBline = gv_fetchpv("dbline", GV_ADDMULTI, SVt_PVAV);
2272     DBsub = gv_HVadd(gv_fetchpv("sub", GV_ADDMULTI, SVt_PVHV));
2273     DBsingle = GvSV((gv_fetchpv("single", GV_ADDMULTI, SVt_PV)));
2274     sv_setiv(DBsingle, 0);
2275     DBtrace = GvSV((gv_fetchpv("trace", GV_ADDMULTI, SVt_PV)));
2276     sv_setiv(DBtrace, 0);
2277     DBsignal = GvSV((gv_fetchpv("signal", GV_ADDMULTI, SVt_PV)));
2278     sv_setiv(DBsignal, 0);
2279     curstash = defstash;
2280 }
2281
2282 static void
2283 init_stacks()
2284 {
2285     curstack = newAV();
2286     mainstack = curstack;               /* remember in case we switch stacks */
2287     AvREAL_off(curstack);               /* not a real array */
2288     av_extend(curstack,127);
2289
2290     stack_base = AvARRAY(curstack);
2291     stack_sp = stack_base;
2292     stack_max = stack_base + 127;
2293
2294     cxstack_max = 8192 / sizeof(CONTEXT) - 2;   /* Use most of 8K. */
2295     New(50,cxstack,cxstack_max + 1,CONTEXT);
2296     cxstack_ix  = -1;
2297
2298     New(50,tmps_stack,128,SV*);
2299     tmps_ix = -1;
2300     tmps_max = 128;
2301
2302     DEBUG( {
2303         New(51,debname,128,char);
2304         New(52,debdelim,128,char);
2305     } )
2306
2307     /*
2308      * The following stacks almost certainly should be per-interpreter,
2309      * but for now they're not.  XXX
2310      */
2311
2312     if (markstack) {
2313         markstack_ptr = markstack;
2314     } else {
2315         New(54,markstack,64,I32);
2316         markstack_ptr = markstack;
2317         markstack_max = markstack + 64;
2318     }
2319
2320     if (scopestack) {
2321         scopestack_ix = 0;
2322     } else {
2323         New(54,scopestack,32,I32);
2324         scopestack_ix = 0;
2325         scopestack_max = 32;
2326     }
2327
2328     if (savestack) {
2329         savestack_ix = 0;
2330     } else {
2331         New(54,savestack,128,ANY);
2332         savestack_ix = 0;
2333         savestack_max = 128;
2334     }
2335
2336     if (retstack) {
2337         retstack_ix = 0;
2338     } else {
2339         New(54,retstack,16,OP*);
2340         retstack_ix = 0;
2341         retstack_max = 16;
2342     }
2343 }
2344
2345 static void
2346 nuke_stacks()
2347 {
2348     Safefree(cxstack);
2349     Safefree(tmps_stack);
2350     DEBUG( {
2351         Safefree(debname);
2352         Safefree(debdelim);
2353     } )
2354 }
2355
2356 static PerlIO *tmpfp;  /* moved outside init_lexer() because of UNICOS bug */
2357
2358 static void
2359 init_lexer()
2360 {
2361     tmpfp = rsfp;
2362     rsfp = Nullfp;
2363     lex_start(linestr);
2364     rsfp = tmpfp;
2365     subname = newSVpv("main",4);
2366 }
2367
2368 static void
2369 init_predump_symbols()
2370 {
2371     GV *tmpgv;
2372     GV *othergv;
2373
2374     sv_setpvn(GvSV(gv_fetchpv("\"", TRUE, SVt_PV)), " ", 1);
2375
2376     stdingv = gv_fetchpv("STDIN",TRUE, SVt_PVIO);
2377     GvMULTI_on(stdingv);
2378     IoIFP(GvIOp(stdingv)) = PerlIO_stdin();
2379     tmpgv = gv_fetchpv("stdin",TRUE, SVt_PV);
2380     GvMULTI_on(tmpgv);
2381     GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(stdingv));
2382
2383     tmpgv = gv_fetchpv("STDOUT",TRUE, SVt_PVIO);
2384     GvMULTI_on(tmpgv);
2385     IoOFP(GvIOp(tmpgv)) = IoIFP(GvIOp(tmpgv)) = PerlIO_stdout();
2386     setdefout(tmpgv);
2387     tmpgv = gv_fetchpv("stdout",TRUE, SVt_PV);
2388     GvMULTI_on(tmpgv);
2389     GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(defoutgv));
2390
2391     othergv = gv_fetchpv("STDERR",TRUE, SVt_PVIO);
2392     GvMULTI_on(othergv);
2393     IoOFP(GvIOp(othergv)) = IoIFP(GvIOp(othergv)) = PerlIO_stderr();
2394     tmpgv = gv_fetchpv("stderr",TRUE, SVt_PV);
2395     GvMULTI_on(tmpgv);
2396     GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(othergv));
2397
2398     statname = NEWSV(66,0);             /* last filename we did stat on */
2399
2400     if (!osname)
2401         osname = savepv(OSNAME);
2402 }
2403
2404 static void
2405 init_postdump_symbols(argc,argv,env)
2406 register int argc;
2407 register char **argv;
2408 register char **env;
2409 {
2410     char *s;
2411     SV *sv;
2412     GV* tmpgv;
2413
2414     argc--,argv++;      /* skip name of script */
2415     if (doswitches) {
2416         for (; argc > 0 && **argv == '-'; argc--,argv++) {
2417             if (!argv[0][1])
2418                 break;
2419             if (argv[0][1] == '-') {
2420                 argc--,argv++;
2421                 break;
2422             }
2423             if (s = strchr(argv[0], '=')) {
2424                 *s++ = '\0';
2425                 sv_setpv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),s);
2426             }
2427             else
2428                 sv_setiv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),1);
2429         }
2430     }
2431     toptarget = NEWSV(0,0);
2432     sv_upgrade(toptarget, SVt_PVFM);
2433     sv_setpvn(toptarget, "", 0);
2434     bodytarget = NEWSV(0,0);
2435     sv_upgrade(bodytarget, SVt_PVFM);
2436     sv_setpvn(bodytarget, "", 0);
2437     formtarget = bodytarget;
2438
2439     TAINT;
2440     if (tmpgv = gv_fetchpv("0",TRUE, SVt_PV)) {
2441         sv_setpv(GvSV(tmpgv),origfilename);
2442         magicname("0", "0", 1);
2443     }
2444     if (tmpgv = gv_fetchpv("\030",TRUE, SVt_PV))
2445         sv_setpv(GvSV(tmpgv),origargv[0]);
2446     if (argvgv = gv_fetchpv("ARGV",TRUE, SVt_PVAV)) {
2447         GvMULTI_on(argvgv);
2448         (void)gv_AVadd(argvgv);
2449         av_clear(GvAVn(argvgv));
2450         for (; argc > 0; argc--,argv++) {
2451             av_push(GvAVn(argvgv),newSVpv(argv[0],0));
2452         }
2453     }
2454     if (envgv = gv_fetchpv("ENV",TRUE, SVt_PVHV)) {
2455         HV *hv;
2456         GvMULTI_on(envgv);
2457         hv = GvHVn(envgv);
2458         hv_magic(hv, envgv, 'E');
2459 #ifndef VMS  /* VMS doesn't have environ array */
2460         /* Note that if the supplied env parameter is actually a copy
2461            of the global environ then it may now point to free'd memory
2462            if the environment has been modified since. To avoid this
2463            problem we treat env==NULL as meaning 'use the default'
2464         */
2465         if (!env)
2466             env = environ;
2467         if (env != environ)
2468             environ[0] = Nullch;
2469         for (; *env; env++) {
2470             if (!(s = strchr(*env,'=')))
2471                 continue;
2472             *s++ = '\0';
2473 #ifdef WIN32
2474             (void)strupr(*env);
2475 #endif
2476             sv = newSVpv(s--,0);
2477             (void)hv_store(hv, *env, s - *env, sv, 0);
2478             *s = '=';
2479 #if defined(__BORLANDC__) && defined(USE_WIN32_RTL_ENV)
2480             /* Sins of the RTL. See note in my_setenv(). */
2481             (void)putenv(savepv(*env));
2482 #endif
2483         }
2484 #endif
2485 #ifdef DYNAMIC_ENV_FETCH
2486         HvNAME(hv) = savepv(ENV_HV_NAME);
2487 #endif
2488     }
2489     TAINT_NOT;
2490     if (tmpgv = gv_fetchpv("$",TRUE, SVt_PV))
2491         sv_setiv(GvSV(tmpgv), (IV)getpid());
2492 }
2493
2494 static void
2495 init_perllib()
2496 {
2497     char *s;
2498     if (!tainting) {
2499 #ifndef VMS
2500         s = getenv("PERL5LIB");
2501         if (s)
2502             incpush(s, TRUE);
2503         else
2504             incpush(getenv("PERLLIB"), FALSE);
2505 #else /* VMS */
2506         /* Treat PERL5?LIB as a possible search list logical name -- the
2507          * "natural" VMS idiom for a Unix path string.  We allow each
2508          * element to be a set of |-separated directories for compatibility.
2509          */
2510         char buf[256];
2511         int idx = 0;
2512         if (my_trnlnm("PERL5LIB",buf,0))
2513             do { incpush(buf,TRUE); } while (my_trnlnm("PERL5LIB",buf,++idx));
2514         else
2515             while (my_trnlnm("PERLLIB",buf,idx++)) incpush(buf,FALSE);
2516 #endif /* VMS */
2517     }
2518
2519 /* Use the ~-expanded versions of APPLLIB (undocumented),
2520     ARCHLIB PRIVLIB SITEARCH SITELIB and OLDARCHLIB
2521 */
2522 #ifdef APPLLIB_EXP
2523     incpush(APPLLIB_EXP, FALSE);
2524 #endif
2525
2526 #ifdef ARCHLIB_EXP
2527     incpush(ARCHLIB_EXP, FALSE);
2528 #endif
2529 #ifndef PRIVLIB_EXP
2530 #define PRIVLIB_EXP "/usr/local/lib/perl5:/usr/local/lib/perl"
2531 #endif
2532     incpush(PRIVLIB_EXP, FALSE);
2533
2534 #ifdef SITEARCH_EXP
2535     incpush(SITEARCH_EXP, FALSE);
2536 #endif
2537 #ifdef SITELIB_EXP
2538     incpush(SITELIB_EXP, FALSE);
2539 #endif
2540 #ifdef OLDARCHLIB_EXP  /* 5.00[01] compatibility */
2541     incpush(OLDARCHLIB_EXP, FALSE);
2542 #endif
2543
2544     if (!tainting)
2545         incpush(".", FALSE);
2546 }
2547
2548 #if defined(DOSISH)
2549 #    define PERLLIB_SEP ';'
2550 #else
2551 #  if defined(VMS)
2552 #    define PERLLIB_SEP '|'
2553 #  else
2554 #    define PERLLIB_SEP ':'
2555 #  endif
2556 #endif
2557 #ifndef PERLLIB_MANGLE
2558 #  define PERLLIB_MANGLE(s,n) (s)
2559 #endif
2560
2561 static void
2562 incpush(p, addsubdirs)
2563 char *p;
2564 int addsubdirs;
2565 {
2566     SV *subdir = Nullsv;
2567     static char *archpat_auto;
2568
2569     if (!p)
2570         return;
2571
2572     if (addsubdirs) {
2573         subdir = newSV(0);
2574         if (!archpat_auto) {
2575             STRLEN len = (sizeof(ARCHNAME) + strlen(patchlevel)
2576                           + sizeof("//auto"));
2577             New(55, archpat_auto, len, char);
2578             sprintf(archpat_auto, "/%s/%s/auto", ARCHNAME, patchlevel);
2579 #ifdef VMS
2580         for (len = sizeof(ARCHNAME) + 2;
2581              archpat_auto[len] != '\0' && archpat_auto[len] != '/'; len++)
2582                 if (archpat_auto[len] == '.') archpat_auto[len] = '_';
2583 #endif
2584         }
2585     }
2586
2587     /* Break at all separators */
2588     while (p && *p) {
2589         SV *libdir = newSV(0);
2590         char *s;
2591
2592         /* skip any consecutive separators */
2593         while ( *p == PERLLIB_SEP ) {
2594             /* Uncomment the next line for PATH semantics */
2595             /* av_push(GvAVn(incgv), newSVpv(".", 1)); */
2596             p++;
2597         }
2598
2599         if ( (s = strchr(p, PERLLIB_SEP)) != Nullch ) {
2600             sv_setpvn(libdir, PERLLIB_MANGLE(p, (STRLEN)(s - p)),
2601                       (STRLEN)(s - p));
2602             p = s + 1;
2603         }
2604         else {
2605             sv_setpv(libdir, PERLLIB_MANGLE(p, 0));
2606             p = Nullch; /* break out */
2607         }
2608
2609         /*
2610          * BEFORE pushing libdir onto @INC we may first push version- and
2611          * archname-specific sub-directories.
2612          */
2613         if (addsubdirs) {
2614             struct stat tmpstatbuf;
2615 #ifdef VMS
2616             char *unix;
2617             STRLEN len;
2618
2619             if ((unix = tounixspec_ts(SvPV(libdir,na),Nullch)) != Nullch) {
2620                 len = strlen(unix);
2621                 while (unix[len-1] == '/') len--;  /* Cosmetic */
2622                 sv_usepvn(libdir,unix,len);
2623             }
2624             else
2625                 PerlIO_printf(PerlIO_stderr(),
2626                               "Failed to unixify @INC element \"%s\"\n",
2627                               SvPV(libdir,na));
2628 #endif
2629             /* .../archname/version if -d .../archname/version/auto */
2630             sv_setsv(subdir, libdir);
2631             sv_catpv(subdir, archpat_auto);
2632             if (Stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
2633                   S_ISDIR(tmpstatbuf.st_mode))
2634                 av_push(GvAVn(incgv),
2635                         newSVpv(SvPVX(subdir), SvCUR(subdir) - sizeof "auto"));
2636
2637             /* .../archname if -d .../archname/auto */
2638             sv_insert(subdir, SvCUR(libdir) + sizeof(ARCHNAME),
2639                       strlen(patchlevel) + 1, "", 0);
2640             if (Stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
2641                   S_ISDIR(tmpstatbuf.st_mode))
2642                 av_push(GvAVn(incgv),
2643                         newSVpv(SvPVX(subdir), SvCUR(subdir) - sizeof "auto"));
2644         }
2645
2646         /* finally push this lib directory on the end of @INC */
2647         av_push(GvAVn(incgv), libdir);
2648     }
2649
2650     SvREFCNT_dec(subdir);
2651 }
2652
2653 void
2654 call_list(oldscope, list)
2655 I32 oldscope;
2656 AV* list;
2657 {
2658     line_t oldline = curcop->cop_line;
2659     STRLEN len;
2660     dJMPENV;
2661     int ret;
2662
2663     while (AvFILL(list) >= 0) {
2664         CV *cv = (CV*)av_shift(list);
2665
2666         SAVEFREESV(cv);
2667
2668         JMPENV_PUSH(ret);
2669         switch (ret) {
2670         case 0: {
2671                 SV* atsv = GvSV(errgv);
2672                 PUSHMARK(stack_sp);
2673                 perl_call_sv((SV*)cv, G_EVAL|G_DISCARD);
2674                 (void)SvPV(atsv, len);
2675                 if (len) {
2676                     JMPENV_POP;
2677                     curcop = &compiling;
2678                     curcop->cop_line = oldline;
2679                     if (list == beginav)
2680                         sv_catpv(atsv, "BEGIN failed--compilation aborted");
2681                     else
2682                         sv_catpv(atsv, "END failed--cleanup aborted");
2683                     while (scopestack_ix > oldscope)
2684                         LEAVE;
2685                     croak("%s", SvPVX(atsv));
2686                 }
2687             }
2688             break;
2689         case 1:
2690             STATUS_ALL_FAILURE;
2691             /* FALL THROUGH */
2692         case 2:
2693             /* my_exit() was called */
2694             while (scopestack_ix > oldscope)
2695                 LEAVE;
2696             FREETMPS;
2697             curstash = defstash;
2698             if (endav)
2699                 call_list(oldscope, endav);
2700             JMPENV_POP;
2701             curcop = &compiling;
2702             curcop->cop_line = oldline;
2703             if (statusvalue) {
2704                 if (list == beginav)
2705                     croak("BEGIN failed--compilation aborted");
2706                 else
2707                     croak("END failed--cleanup aborted");
2708             }
2709             my_exit_jump();
2710             /* NOTREACHED */
2711         case 3:
2712             if (!restartop) {
2713                 PerlIO_printf(PerlIO_stderr(), "panic: restartop\n");
2714                 FREETMPS;
2715                 break;
2716             }
2717             JMPENV_POP;
2718             curcop = &compiling;
2719             curcop->cop_line = oldline;
2720             JMPENV_JUMP(3);
2721         }
2722         JMPENV_POP;
2723     }
2724 }
2725
2726 void
2727 my_exit(status)
2728 U32 status;
2729 {
2730     switch (status) {
2731     case 0:
2732         STATUS_ALL_SUCCESS;
2733         break;
2734     case 1:
2735         STATUS_ALL_FAILURE;
2736         break;
2737     default:
2738         STATUS_NATIVE_SET(status);
2739         break;
2740     }
2741     my_exit_jump();
2742 }
2743
2744 void
2745 my_failure_exit()
2746 {
2747 #ifdef VMS
2748     if (vaxc$errno & 1) {
2749         if (STATUS_NATIVE & 1)          /* fortuitiously includes "-1" */
2750             STATUS_NATIVE_SET(44);
2751     }
2752     else {
2753         if (!vaxc$errno && errno)       /* unlikely */
2754             STATUS_NATIVE_SET(44);
2755         else
2756             STATUS_NATIVE_SET(vaxc$errno);
2757     }
2758 #else
2759     if (errno & 255)
2760         STATUS_POSIX_SET(errno);
2761     else if (STATUS_POSIX == 0)
2762         STATUS_POSIX_SET(255);
2763 #endif
2764     my_exit_jump();
2765 }
2766
2767 static void
2768 my_exit_jump()
2769 {
2770     register CONTEXT *cx;
2771     I32 gimme;
2772     SV **newsp;
2773
2774     if (e_tmpname) {
2775         if (e_fp) {
2776             PerlIO_close(e_fp);
2777             e_fp = Nullfp;
2778         }
2779         (void)UNLINK(e_tmpname);
2780         Safefree(e_tmpname);
2781         e_tmpname = Nullch;
2782     }
2783
2784     if (cxstack_ix >= 0) {
2785         if (cxstack_ix > 0)
2786             dounwind(0);
2787         POPBLOCK(cx,curpm);
2788         LEAVE;
2789     }
2790
2791     JMPENV_JUMP(2);
2792 }