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