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