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 than once)");
1301     printf("\n  -l[octal]       enable line ending processing, specifies line terminator");
1302     printf("\n  -[mM][-]module.. executes `use/no module...' before executing your script.");
1303     printf("\n  -n              assume 'while (<>) { ... }' loop around 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         bool seen_dot = 1;
1673
1674         hasdir = (strpbrk(scriptname,":[</") != Nullch) ;
1675         /* The first time through, just add SEARCH_EXTS to whatever we
1676          * already have, so we can check for default file types. */
1677         while (deftypes ||
1678                (!hasdir && my_trnlnm("DCL$PATH",tokenbuf,idx++)) )
1679         {
1680             if (deftypes) {
1681                 deftypes = 0;
1682                 *tokenbuf = '\0';
1683             }
1684             if ((strlen(tokenbuf) + strlen(scriptname)
1685                  + MAX_EXT_LEN) >= sizeof tokenbuf)
1686                 continue;       /* don't search dir with too-long name */
1687             strcat(tokenbuf, scriptname);
1688 #else  /* !VMS */
1689
1690 #ifdef DOSISH
1691     if (strEQ(scriptname, "-"))
1692         dosearch = 0;
1693     if (dosearch) {             /* Look in '.' first. */
1694         char *cur = scriptname;
1695 #ifdef SEARCH_EXTS
1696         if ((curext = strrchr(scriptname,'.'))) /* possible current ext */
1697             while (ext[i])
1698                 if (strEQ(ext[i++],curext)) {
1699                     extidx = -1;                /* already has an ext */
1700                     break;
1701                 }
1702         do {
1703 #endif
1704             DEBUG_p(PerlIO_printf(Perl_debug_log,
1705                                   "Looking for %s\n",cur));
1706             if (Stat(cur,&statbuf) >= 0) {
1707                 dosearch = 0;
1708                 scriptname = cur;
1709 #ifdef SEARCH_EXTS
1710                 break;
1711 #endif
1712             }
1713 #ifdef SEARCH_EXTS
1714             if (cur == scriptname) {
1715                 len = strlen(scriptname);
1716                 if (len+MAX_EXT_LEN+1 >= sizeof(tokenbuf))
1717                     break;
1718                 cur = strcpy(tokenbuf, scriptname);
1719             }
1720         } while (extidx >= 0 && ext[extidx]     /* try an extension? */
1721                  && strcpy(tokenbuf+len, ext[extidx++]));
1722 #endif
1723     }
1724 #endif
1725
1726     if (dosearch && !strchr(scriptname, '/')
1727 #ifdef DOSISH
1728                  && !strchr(scriptname, '\\')
1729 #endif
1730                  && (s = getenv("PATH"))) {
1731         bool seen_dot = 0;
1732
1733         bufend = s + strlen(s);
1734         while (s < bufend) {
1735 #if defined(atarist) || defined(DOSISH)
1736             for (len = 0; *s
1737 #  ifdef atarist
1738                     && *s != ','
1739 #  endif
1740                     && *s != ';'; len++, s++) {
1741                 if (len < sizeof tokenbuf)
1742                     tokenbuf[len] = *s;
1743             }
1744             if (len < sizeof tokenbuf)
1745                 tokenbuf[len] = '\0';
1746 #else  /* ! (atarist || DOSISH) */
1747             s = delimcpy(tokenbuf, tokenbuf + sizeof tokenbuf, s, bufend,
1748                         ':',
1749                         &len);
1750 #endif /* ! (atarist || DOSISH) */
1751             if (s < bufend)
1752                 s++;
1753             if (len + 1 + strlen(scriptname) + MAX_EXT_LEN >= sizeof tokenbuf)
1754                 continue;       /* don't search dir with too-long name */
1755             if (len
1756 #if defined(atarist) || defined(DOSISH)
1757                 && tokenbuf[len - 1] != '/'
1758                 && tokenbuf[len - 1] != '\\'
1759 #endif
1760                )
1761                 tokenbuf[len++] = '/';
1762             if (len == 2 && tokenbuf[0] == '.')
1763                 seen_dot = 1;
1764             (void)strcpy(tokenbuf + len, scriptname);
1765 #endif  /* !VMS */
1766
1767 #ifdef SEARCH_EXTS
1768             len = strlen(tokenbuf);
1769             if (extidx > 0)     /* reset after previous loop */
1770                 extidx = 0;
1771             do {
1772 #endif
1773                 DEBUG_p(PerlIO_printf(Perl_debug_log, "Looking for %s\n",tokenbuf));
1774                 retval = Stat(tokenbuf,&statbuf);
1775 #ifdef SEARCH_EXTS
1776             } while (  retval < 0               /* not there */
1777                     && extidx>=0 && ext[extidx] /* try an extension? */
1778                     && strcpy(tokenbuf+len, ext[extidx++])
1779                 );
1780 #endif
1781             if (retval < 0)
1782                 continue;
1783             if (S_ISREG(statbuf.st_mode)
1784                 && cando(S_IRUSR,TRUE,&statbuf)
1785 #ifndef DOSISH
1786                 && cando(S_IXUSR,TRUE,&statbuf)
1787 #endif
1788                 )
1789             {
1790                 xfound = tokenbuf;              /* bingo! */
1791                 break;
1792             }
1793             if (!xfailed)
1794                 xfailed = savepv(tokenbuf);
1795         }
1796 #ifndef DOSISH
1797         if (!xfound && !seen_dot && !xfailed && (Stat(scriptname,&statbuf) < 0))
1798 #endif
1799             seen_dot = 1;                       /* Disable message. */
1800         if (!xfound)
1801             croak("Can't %s %s%s%s",
1802                   (xfailed ? "execute" : "find"),
1803                   (xfailed ? xfailed : scriptname),
1804                   (xfailed ? "" : " on PATH"),
1805                   (xfailed || seen_dot) ? "" : ", '.' not in PATH");
1806         if (xfailed)
1807             Safefree(xfailed);
1808         scriptname = xfound;
1809     }
1810
1811     if (strnEQ(scriptname, "/dev/fd/", 8) && isDIGIT(scriptname[8]) ) {
1812         char *s = scriptname + 8;
1813         fdscript = atoi(s);
1814         while (isDIGIT(*s))
1815             s++;
1816         if (*s)
1817             scriptname = s + 1;
1818     }
1819     else
1820         fdscript = -1;
1821     origfilename = savepv(e_tmpname ? "-e" : scriptname);
1822     curcop->cop_filegv = gv_fetchfile(origfilename);
1823     if (strEQ(origfilename,"-"))
1824         scriptname = "";
1825     if (fdscript >= 0) {
1826         rsfp = PerlIO_fdopen(fdscript,"r");
1827 #if defined(HAS_FCNTL) && defined(F_SETFD)
1828         if (rsfp)
1829             fcntl(PerlIO_fileno(rsfp),F_SETFD,1);  /* ensure close-on-exec */
1830 #endif
1831     }
1832     else if (preprocess) {
1833         char *cpp_cfg = CPPSTDIN;
1834         SV *cpp = NEWSV(0,0);
1835         SV *cmd = NEWSV(0,0);
1836
1837         if (strEQ(cpp_cfg, "cppstdin"))
1838             sv_catpvf(cpp, "%s/", BIN_EXP);
1839         sv_catpv(cpp, cpp_cfg);
1840
1841         sv_catpv(sv,"-I");
1842         sv_catpv(sv,PRIVLIB_EXP);
1843
1844 #ifdef MSDOS
1845         sv_setpvf(cmd, "\
1846 sed %s -e \"/^[^#]/b\" \
1847  -e \"/^#[      ]*include[      ]/b\" \
1848  -e \"/^#[      ]*define[       ]/b\" \
1849  -e \"/^#[      ]*if[   ]/b\" \
1850  -e \"/^#[      ]*ifdef[        ]/b\" \
1851  -e \"/^#[      ]*ifndef[       ]/b\" \
1852  -e \"/^#[      ]*else/b\" \
1853  -e \"/^#[      ]*elif[         ]/b\" \
1854  -e \"/^#[      ]*undef[        ]/b\" \
1855  -e \"/^#[      ]*endif/b\" \
1856  -e \"s/^#.*//\" \
1857  %s | %_ -C %_ %s",
1858           (doextract ? "-e \"1,/^#/d\n\"" : ""),
1859 #else
1860         sv_setpvf(cmd, "\
1861 %s %s -e '/^[^#]/b' \
1862  -e '/^#[       ]*include[      ]/b' \
1863  -e '/^#[       ]*define[       ]/b' \
1864  -e '/^#[       ]*if[   ]/b' \
1865  -e '/^#[       ]*ifdef[        ]/b' \
1866  -e '/^#[       ]*ifndef[       ]/b' \
1867  -e '/^#[       ]*else/b' \
1868  -e '/^#[       ]*elif[         ]/b' \
1869  -e '/^#[       ]*undef[        ]/b' \
1870  -e '/^#[       ]*endif/b' \
1871  -e 's/^[       ]*#.*//' \
1872  %s | %_ -C %_ %s",
1873 #ifdef LOC_SED
1874           LOC_SED,
1875 #else
1876           "sed",
1877 #endif
1878           (doextract ? "-e '1,/^#/d\n'" : ""),
1879 #endif
1880           scriptname, cpp, sv, CPPMINUS);
1881         doextract = FALSE;
1882 #ifdef IAMSUID                          /* actually, this is caught earlier */
1883         if (euid != uid && !euid) {     /* if running suidperl */
1884 #ifdef HAS_SETEUID
1885             (void)seteuid(uid);         /* musn't stay setuid root */
1886 #else
1887 #ifdef HAS_SETREUID
1888             (void)setreuid((Uid_t)-1, uid);
1889 #else
1890 #ifdef HAS_SETRESUID
1891             (void)setresuid((Uid_t)-1, uid, (Uid_t)-1);
1892 #else
1893             setuid(uid);
1894 #endif
1895 #endif
1896 #endif
1897             if (geteuid() != uid)
1898                 croak("Can't do seteuid!\n");
1899         }
1900 #endif /* IAMSUID */
1901         rsfp = my_popen(SvPVX(cmd), "r");
1902         SvREFCNT_dec(cmd);
1903         SvREFCNT_dec(cpp);
1904     }
1905     else if (!*scriptname) {
1906         forbid_setid("program input from stdin");
1907         rsfp = PerlIO_stdin();
1908     }
1909     else {
1910         rsfp = PerlIO_open(scriptname,"r");
1911 #if defined(HAS_FCNTL) && defined(F_SETFD)
1912         if (rsfp)
1913             fcntl(PerlIO_fileno(rsfp),F_SETFD,1);  /* ensure close-on-exec */
1914 #endif
1915     }
1916     if (e_tmpname) {
1917         e_fp = rsfp;
1918     }
1919     if (!rsfp) {
1920 #ifdef DOSUID
1921 #ifndef IAMSUID         /* in case script is not readable before setuid */
1922         if (euid && Stat(SvPVX(GvSV(curcop->cop_filegv)),&statbuf) >= 0 &&
1923           statbuf.st_mode & (S_ISUID|S_ISGID)) {
1924             /* try again */
1925             execv(form("%s/sperl%s", BIN_EXP, patchlevel), origargv);
1926             croak("Can't do setuid\n");
1927         }
1928 #endif
1929 #endif
1930         croak("Can't open perl script \"%s\": %s\n",
1931           SvPVX(GvSV(curcop->cop_filegv)), Strerror(errno));
1932     }
1933 }
1934
1935 static void
1936 validate_suid(validarg, scriptname)
1937 char *validarg;
1938 char *scriptname;
1939 {
1940     int which;
1941
1942     /* do we need to emulate setuid on scripts? */
1943
1944     /* This code is for those BSD systems that have setuid #! scripts disabled
1945      * in the kernel because of a security problem.  Merely defining DOSUID
1946      * in perl will not fix that problem, but if you have disabled setuid
1947      * scripts in the kernel, this will attempt to emulate setuid and setgid
1948      * on scripts that have those now-otherwise-useless bits set.  The setuid
1949      * root version must be called suidperl or sperlN.NNN.  If regular perl
1950      * discovers that it has opened a setuid script, it calls suidperl with
1951      * the same argv that it had.  If suidperl finds that the script it has
1952      * just opened is NOT setuid root, it sets the effective uid back to the
1953      * uid.  We don't just make perl setuid root because that loses the
1954      * effective uid we had before invoking perl, if it was different from the
1955      * uid.
1956      *
1957      * DOSUID must be defined in both perl and suidperl, and IAMSUID must
1958      * be defined in suidperl only.  suidperl must be setuid root.  The
1959      * Configure script will set this up for you if you want it.
1960      */
1961
1962 #ifdef DOSUID
1963     char *s, *s2;
1964
1965     if (Fstat(PerlIO_fileno(rsfp),&statbuf) < 0)        /* normal stat is insecure */
1966         croak("Can't stat script \"%s\"",origfilename);
1967     if (fdscript < 0 && statbuf.st_mode & (S_ISUID|S_ISGID)) {
1968         I32 len;
1969
1970 #ifdef IAMSUID
1971 #ifndef HAS_SETREUID
1972         /* On this access check to make sure the directories are readable,
1973          * there is actually a small window that the user could use to make
1974          * filename point to an accessible directory.  So there is a faint
1975          * chance that someone could execute a setuid script down in a
1976          * non-accessible directory.  I don't know what to do about that.
1977          * But I don't think it's too important.  The manual lies when
1978          * it says access() is useful in setuid programs.
1979          */
1980         if (access(SvPVX(GvSV(curcop->cop_filegv)),1))  /*double check*/
1981             croak("Permission denied");
1982 #else
1983         /* If we can swap euid and uid, then we can determine access rights
1984          * with a simple stat of the file, and then compare device and
1985          * inode to make sure we did stat() on the same file we opened.
1986          * Then we just have to make sure he or she can execute it.
1987          */
1988         {
1989             struct stat tmpstatbuf;
1990
1991             if (
1992 #ifdef HAS_SETREUID
1993                 setreuid(euid,uid) < 0
1994 #else
1995 # if HAS_SETRESUID
1996                 setresuid(euid,uid,(Uid_t)-1) < 0
1997 # endif
1998 #endif
1999                 || getuid() != euid || geteuid() != uid)
2000                 croak("Can't swap uid and euid");       /* really paranoid */
2001             if (Stat(SvPVX(GvSV(curcop->cop_filegv)),&tmpstatbuf) < 0)
2002                 croak("Permission denied");     /* testing full pathname here */
2003             if (tmpstatbuf.st_dev != statbuf.st_dev ||
2004                 tmpstatbuf.st_ino != statbuf.st_ino) {
2005                 (void)PerlIO_close(rsfp);
2006                 if (rsfp = my_popen("/bin/mail root","w")) {    /* heh, heh */
2007                     PerlIO_printf(rsfp,
2008 "User %ld tried to run dev %ld ino %ld in place of dev %ld ino %ld!\n\
2009 (Filename of set-id script was %s, uid %ld gid %ld.)\n\nSincerely,\nperl\n",
2010                         (long)uid,(long)tmpstatbuf.st_dev, (long)tmpstatbuf.st_ino,
2011                         (long)statbuf.st_dev, (long)statbuf.st_ino,
2012                         SvPVX(GvSV(curcop->cop_filegv)),
2013                         (long)statbuf.st_uid, (long)statbuf.st_gid);
2014                     (void)my_pclose(rsfp);
2015                 }
2016                 croak("Permission denied\n");
2017             }
2018             if (
2019 #ifdef HAS_SETREUID
2020               setreuid(uid,euid) < 0
2021 #else
2022 # if defined(HAS_SETRESUID)
2023               setresuid(uid,euid,(Uid_t)-1) < 0
2024 # endif
2025 #endif
2026               || getuid() != uid || geteuid() != euid)
2027                 croak("Can't reswap uid and euid");
2028             if (!cando(S_IXUSR,FALSE,&statbuf))         /* can real uid exec? */
2029                 croak("Permission denied\n");
2030         }
2031 #endif /* HAS_SETREUID */
2032 #endif /* IAMSUID */
2033
2034         if (!S_ISREG(statbuf.st_mode))
2035             croak("Permission denied");
2036         if (statbuf.st_mode & S_IWOTH)
2037             croak("Setuid/gid script is writable by world");
2038         doswitches = FALSE;             /* -s is insecure in suid */
2039         curcop->cop_line++;
2040         if (sv_gets(linestr, rsfp, 0) == Nullch ||
2041           strnNE(SvPV(linestr,na),"#!",2) )     /* required even on Sys V */
2042             croak("No #! line");
2043         s = SvPV(linestr,na)+2;
2044         if (*s == ' ') s++;
2045         while (!isSPACE(*s)) s++;
2046         for (s2 = s;  (s2 > SvPV(linestr,na)+2 &&
2047                        (isDIGIT(s2[-1]) || strchr("._-", s2[-1])));  s2--) ;
2048         if (strnNE(s2-4,"perl",4) && strnNE(s-9,"perl",4))  /* sanity check */
2049             croak("Not a perl script");
2050         while (*s == ' ' || *s == '\t') s++;
2051         /*
2052          * #! arg must be what we saw above.  They can invoke it by
2053          * mentioning suidperl explicitly, but they may not add any strange
2054          * arguments beyond what #! says if they do invoke suidperl that way.
2055          */
2056         len = strlen(validarg);
2057         if (strEQ(validarg," PHOOEY ") ||
2058             strnNE(s,validarg,len) || !isSPACE(s[len]))
2059             croak("Args must match #! line");
2060
2061 #ifndef IAMSUID
2062         if (euid != uid && (statbuf.st_mode & S_ISUID) &&
2063             euid == statbuf.st_uid)
2064             if (!do_undump)
2065                 croak("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
2066 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
2067 #endif /* IAMSUID */
2068
2069         if (euid) {     /* oops, we're not the setuid root perl */
2070             (void)PerlIO_close(rsfp);
2071 #ifndef IAMSUID
2072             /* try again */
2073             execv(form("%s/sperl%s", BIN_EXP, patchlevel), origargv);
2074 #endif
2075             croak("Can't do setuid\n");
2076         }
2077
2078         if (statbuf.st_mode & S_ISGID && statbuf.st_gid != egid) {
2079 #ifdef HAS_SETEGID
2080             (void)setegid(statbuf.st_gid);
2081 #else
2082 #ifdef HAS_SETREGID
2083            (void)setregid((Gid_t)-1,statbuf.st_gid);
2084 #else
2085 #ifdef HAS_SETRESGID
2086            (void)setresgid((Gid_t)-1,statbuf.st_gid,(Gid_t)-1);
2087 #else
2088             setgid(statbuf.st_gid);
2089 #endif
2090 #endif
2091 #endif
2092             if (getegid() != statbuf.st_gid)
2093                 croak("Can't do setegid!\n");
2094         }
2095         if (statbuf.st_mode & S_ISUID) {
2096             if (statbuf.st_uid != euid)
2097 #ifdef HAS_SETEUID
2098                 (void)seteuid(statbuf.st_uid);  /* all that for this */
2099 #else
2100 #ifdef HAS_SETREUID
2101                 (void)setreuid((Uid_t)-1,statbuf.st_uid);
2102 #else
2103 #ifdef HAS_SETRESUID
2104                 (void)setresuid((Uid_t)-1,statbuf.st_uid,(Uid_t)-1);
2105 #else
2106                 setuid(statbuf.st_uid);
2107 #endif
2108 #endif
2109 #endif
2110             if (geteuid() != statbuf.st_uid)
2111                 croak("Can't do seteuid!\n");
2112         }
2113         else if (uid) {                 /* oops, mustn't run as root */
2114 #ifdef HAS_SETEUID
2115           (void)seteuid((Uid_t)uid);
2116 #else
2117 #ifdef HAS_SETREUID
2118           (void)setreuid((Uid_t)-1,(Uid_t)uid);
2119 #else
2120 #ifdef HAS_SETRESUID
2121           (void)setresuid((Uid_t)-1,(Uid_t)uid,(Uid_t)-1);
2122 #else
2123           setuid((Uid_t)uid);
2124 #endif
2125 #endif
2126 #endif
2127             if (geteuid() != uid)
2128                 croak("Can't do seteuid!\n");
2129         }
2130         init_ids();
2131         if (!cando(S_IXUSR,TRUE,&statbuf))
2132             croak("Permission denied\n");       /* they can't do this */
2133     }
2134 #ifdef IAMSUID
2135     else if (preprocess)
2136         croak("-P not allowed for setuid/setgid script\n");
2137     else if (fdscript >= 0)
2138         croak("fd script not allowed in suidperl\n");
2139     else
2140         croak("Script is not setuid/setgid in suidperl\n");
2141
2142     /* We absolutely must clear out any saved ids here, so we */
2143     /* exec the real perl, substituting fd script for scriptname. */
2144     /* (We pass script name as "subdir" of fd, which perl will grok.) */
2145     PerlIO_rewind(rsfp);
2146     lseek(PerlIO_fileno(rsfp),(Off_t)0,0);  /* just in case rewind didn't */
2147     for (which = 1; origargv[which] && origargv[which] != scriptname; which++) ;
2148     if (!origargv[which])
2149         croak("Permission denied");
2150     origargv[which] = savepv(form("/dev/fd/%d/%s",
2151                                   PerlIO_fileno(rsfp), origargv[which]));
2152 #if defined(HAS_FCNTL) && defined(F_SETFD)
2153     fcntl(PerlIO_fileno(rsfp),F_SETFD,0);       /* ensure no close-on-exec */
2154 #endif
2155     execv(form("%s/perl%s", BIN_EXP, patchlevel), origargv);    /* try again */
2156     croak("Can't do setuid\n");
2157 #endif /* IAMSUID */
2158 #else /* !DOSUID */
2159     if (euid != uid || egid != gid) {   /* (suidperl doesn't exist, in fact) */
2160 #ifndef SETUID_SCRIPTS_ARE_SECURE_NOW
2161         Fstat(PerlIO_fileno(rsfp),&statbuf);    /* may be either wrapped or real suid */
2162         if ((euid != uid && euid == statbuf.st_uid && statbuf.st_mode & S_ISUID)
2163             ||
2164             (egid != gid && egid == statbuf.st_gid && statbuf.st_mode & S_ISGID)
2165            )
2166             if (!do_undump)
2167                 croak("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
2168 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
2169 #endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
2170         /* not set-id, must be wrapped */
2171     }
2172 #endif /* DOSUID */
2173 }
2174
2175 static void
2176 find_beginning()
2177 {
2178     register char *s, *s2;
2179
2180     /* skip forward in input to the real script? */
2181
2182     forbid_setid("-x");
2183     while (doextract) {
2184         if ((s = sv_gets(linestr, rsfp, 0)) == Nullch)
2185             croak("No Perl script found in input\n");
2186         if (*s == '#' && s[1] == '!' && (s = instr(s,"perl"))) {
2187             PerlIO_ungetc(rsfp, '\n');          /* to keep line count right */
2188             doextract = FALSE;
2189             while (*s && !(isSPACE (*s) || *s == '#')) s++;
2190             s2 = s;
2191             while (*s == ' ' || *s == '\t') s++;
2192             if (*s++ == '-') {
2193                 while (isDIGIT(s2[-1]) || strchr("-._", s2[-1])) s2--;
2194                 if (strnEQ(s2-4,"perl",4))
2195                     /*SUPPRESS 530*/
2196                     while (s = moreswitches(s)) ;
2197             }
2198             if (cddir && chdir(cddir) < 0)
2199                 croak("Can't chdir to %s",cddir);
2200         }
2201     }
2202 }
2203
2204 static void
2205 init_ids()
2206 {
2207     uid = (int)getuid();
2208     euid = (int)geteuid();
2209     gid = (int)getgid();
2210     egid = (int)getegid();
2211 #ifdef VMS
2212     uid |= gid << 16;
2213     euid |= egid << 16;
2214 #endif
2215     tainting |= (uid && (euid != uid || egid != gid));
2216 }
2217
2218 static void
2219 forbid_setid(s)
2220 char *s;
2221 {
2222     if (euid != uid)
2223         croak("No %s allowed while running setuid", s);
2224     if (egid != gid)
2225         croak("No %s allowed while running setgid", s);
2226 }
2227
2228 static void
2229 init_debugger()
2230 {
2231     curstash = debstash;
2232     dbargs = GvAV(gv_AVadd((gv_fetchpv("args", GV_ADDMULTI, SVt_PVAV))));
2233     AvREAL_off(dbargs);
2234     DBgv = gv_fetchpv("DB", GV_ADDMULTI, SVt_PVGV);
2235     DBline = gv_fetchpv("dbline", GV_ADDMULTI, SVt_PVAV);
2236     DBsub = gv_HVadd(gv_fetchpv("sub", GV_ADDMULTI, SVt_PVHV));
2237     DBsingle = GvSV((gv_fetchpv("single", GV_ADDMULTI, SVt_PV)));
2238     sv_setiv(DBsingle, 0);
2239     DBtrace = GvSV((gv_fetchpv("trace", GV_ADDMULTI, SVt_PV)));
2240     sv_setiv(DBtrace, 0);
2241     DBsignal = GvSV((gv_fetchpv("signal", GV_ADDMULTI, SVt_PV)));
2242     sv_setiv(DBsignal, 0);
2243     curstash = defstash;
2244 }
2245
2246 static void
2247 init_stacks()
2248 {
2249     curstack = newAV();
2250     mainstack = curstack;               /* remember in case we switch stacks */
2251     AvREAL_off(curstack);               /* not a real array */
2252     av_extend(curstack,127);
2253
2254     stack_base = AvARRAY(curstack);
2255     stack_sp = stack_base;
2256     stack_max = stack_base + 127;
2257
2258     cxstack_max = 8192 / sizeof(CONTEXT) - 2;   /* Use most of 8K. */
2259     New(50,cxstack,cxstack_max + 1,CONTEXT);
2260     cxstack_ix  = -1;
2261
2262     New(50,tmps_stack,128,SV*);
2263     tmps_ix = -1;
2264     tmps_max = 128;
2265
2266     DEBUG( {
2267         New(51,debname,128,char);
2268         New(52,debdelim,128,char);
2269     } )
2270
2271     /*
2272      * The following stacks almost certainly should be per-interpreter,
2273      * but for now they're not.  XXX
2274      */
2275
2276     if (markstack) {
2277         markstack_ptr = markstack;
2278     } else {
2279         New(54,markstack,64,I32);
2280         markstack_ptr = markstack;
2281         markstack_max = markstack + 64;
2282     }
2283
2284     if (scopestack) {
2285         scopestack_ix = 0;
2286     } else {
2287         New(54,scopestack,32,I32);
2288         scopestack_ix = 0;
2289         scopestack_max = 32;
2290     }
2291
2292     if (savestack) {
2293         savestack_ix = 0;
2294     } else {
2295         New(54,savestack,128,ANY);
2296         savestack_ix = 0;
2297         savestack_max = 128;
2298     }
2299
2300     if (retstack) {
2301         retstack_ix = 0;
2302     } else {
2303         New(54,retstack,16,OP*);
2304         retstack_ix = 0;
2305         retstack_max = 16;
2306     }
2307 }
2308
2309 static void
2310 nuke_stacks()
2311 {
2312     Safefree(cxstack);
2313     Safefree(tmps_stack);
2314     DEBUG( {
2315         Safefree(debname);
2316         Safefree(debdelim);
2317     } )
2318 }
2319
2320 static PerlIO *tmpfp;  /* moved outside init_lexer() because of UNICOS bug */
2321
2322 static void
2323 init_lexer()
2324 {
2325     tmpfp = rsfp;
2326     lex_start(linestr);
2327     rsfp = tmpfp;
2328     subname = newSVpv("main",4);
2329 }
2330
2331 static void
2332 init_predump_symbols()
2333 {
2334     GV *tmpgv;
2335     GV *othergv;
2336
2337     sv_setpvn(GvSV(gv_fetchpv("\"", TRUE, SVt_PV)), " ", 1);
2338
2339     stdingv = gv_fetchpv("STDIN",TRUE, SVt_PVIO);
2340     GvMULTI_on(stdingv);
2341     IoIFP(GvIOp(stdingv)) = PerlIO_stdin();
2342     tmpgv = gv_fetchpv("stdin",TRUE, SVt_PV);
2343     GvMULTI_on(tmpgv);
2344     GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(stdingv));
2345
2346     tmpgv = gv_fetchpv("STDOUT",TRUE, SVt_PVIO);
2347     GvMULTI_on(tmpgv);
2348     IoOFP(GvIOp(tmpgv)) = IoIFP(GvIOp(tmpgv)) = PerlIO_stdout();
2349     setdefout(tmpgv);
2350     tmpgv = gv_fetchpv("stdout",TRUE, SVt_PV);
2351     GvMULTI_on(tmpgv);
2352     GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(defoutgv));
2353
2354     othergv = gv_fetchpv("STDERR",TRUE, SVt_PVIO);
2355     GvMULTI_on(othergv);
2356     IoOFP(GvIOp(othergv)) = IoIFP(GvIOp(othergv)) = PerlIO_stderr();
2357     tmpgv = gv_fetchpv("stderr",TRUE, SVt_PV);
2358     GvMULTI_on(tmpgv);
2359     GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(othergv));
2360
2361     statname = NEWSV(66,0);             /* last filename we did stat on */
2362
2363     if (!osname)
2364         osname = savepv(OSNAME);
2365 }
2366
2367 static void
2368 init_postdump_symbols(argc,argv,env)
2369 register int argc;
2370 register char **argv;
2371 register char **env;
2372 {
2373     char *s;
2374     SV *sv;
2375     GV* tmpgv;
2376
2377     argc--,argv++;      /* skip name of script */
2378     if (doswitches) {
2379         for (; argc > 0 && **argv == '-'; argc--,argv++) {
2380             if (!argv[0][1])
2381                 break;
2382             if (argv[0][1] == '-') {
2383                 argc--,argv++;
2384                 break;
2385             }
2386             if (s = strchr(argv[0], '=')) {
2387                 *s++ = '\0';
2388                 sv_setpv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),s);
2389             }
2390             else
2391                 sv_setiv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),1);
2392         }
2393     }
2394     toptarget = NEWSV(0,0);
2395     sv_upgrade(toptarget, SVt_PVFM);
2396     sv_setpvn(toptarget, "", 0);
2397     bodytarget = NEWSV(0,0);
2398     sv_upgrade(bodytarget, SVt_PVFM);
2399     sv_setpvn(bodytarget, "", 0);
2400     formtarget = bodytarget;
2401
2402     TAINT;
2403     if (tmpgv = gv_fetchpv("0",TRUE, SVt_PV)) {
2404         sv_setpv(GvSV(tmpgv),origfilename);
2405         magicname("0", "0", 1);
2406     }
2407     if (tmpgv = gv_fetchpv("\030",TRUE, SVt_PV))
2408         sv_setpv(GvSV(tmpgv),origargv[0]);
2409     if (argvgv = gv_fetchpv("ARGV",TRUE, SVt_PVAV)) {
2410         GvMULTI_on(argvgv);
2411         (void)gv_AVadd(argvgv);
2412         av_clear(GvAVn(argvgv));
2413         for (; argc > 0; argc--,argv++) {
2414             av_push(GvAVn(argvgv),newSVpv(argv[0],0));
2415         }
2416     }
2417     if (envgv = gv_fetchpv("ENV",TRUE, SVt_PVHV)) {
2418         HV *hv;
2419         GvMULTI_on(envgv);
2420         hv = GvHVn(envgv);
2421         hv_magic(hv, envgv, 'E');
2422 #ifndef VMS  /* VMS doesn't have environ array */
2423         /* Note that if the supplied env parameter is actually a copy
2424            of the global environ then it may now point to free'd memory
2425            if the environment has been modified since. To avoid this
2426            problem we treat env==NULL as meaning 'use the default'
2427         */
2428         if (!env)
2429             env = environ;
2430         if (env != environ)
2431             environ[0] = Nullch;
2432         for (; *env; env++) {
2433             if (!(s = strchr(*env,'=')))
2434                 continue;
2435             *s++ = '\0';
2436 #ifdef WIN32
2437             (void)strupr(*env);
2438 #endif
2439             sv = newSVpv(s--,0);
2440             (void)hv_store(hv, *env, s - *env, sv, 0);
2441             *s = '=';
2442 #if defined(__BORLANDC__) && defined(USE_WIN32_RTL_ENV)
2443             /* Sins of the RTL. See note in my_setenv(). */
2444             (void)putenv(savepv(*env));
2445 #endif
2446         }
2447 #endif
2448 #ifdef DYNAMIC_ENV_FETCH
2449         HvNAME(hv) = savepv(ENV_HV_NAME);
2450 #endif
2451     }
2452     TAINT_NOT;
2453     if (tmpgv = gv_fetchpv("$",TRUE, SVt_PV))
2454         sv_setiv(GvSV(tmpgv), (IV)getpid());
2455 }
2456
2457 static void
2458 init_perllib()
2459 {
2460     char *s;
2461     if (!tainting) {
2462 #ifndef VMS
2463         s = getenv("PERL5LIB");
2464         if (s)
2465             incpush(s, TRUE);
2466         else
2467             incpush(getenv("PERLLIB"), FALSE);
2468 #else /* VMS */
2469         /* Treat PERL5?LIB as a possible search list logical name -- the
2470          * "natural" VMS idiom for a Unix path string.  We allow each
2471          * element to be a set of |-separated directories for compatibility.
2472          */
2473         char buf[256];
2474         int idx = 0;
2475         if (my_trnlnm("PERL5LIB",buf,0))
2476             do { incpush(buf,TRUE); } while (my_trnlnm("PERL5LIB",buf,++idx));
2477         else
2478             while (my_trnlnm("PERLLIB",buf,idx++)) incpush(buf,FALSE);
2479 #endif /* VMS */
2480     }
2481
2482 /* Use the ~-expanded versions of APPLLIB (undocumented),
2483     ARCHLIB PRIVLIB SITEARCH SITELIB and OLDARCHLIB
2484 */
2485 #ifdef APPLLIB_EXP
2486     incpush(APPLLIB_EXP, FALSE);
2487 #endif
2488
2489 #ifdef ARCHLIB_EXP
2490     incpush(ARCHLIB_EXP, FALSE);
2491 #endif
2492 #ifndef PRIVLIB_EXP
2493 #define PRIVLIB_EXP "/usr/local/lib/perl5:/usr/local/lib/perl"
2494 #endif
2495     incpush(PRIVLIB_EXP, FALSE);
2496
2497 #ifdef SITEARCH_EXP
2498     incpush(SITEARCH_EXP, FALSE);
2499 #endif
2500 #ifdef SITELIB_EXP
2501     incpush(SITELIB_EXP, FALSE);
2502 #endif
2503 #ifdef OLDARCHLIB_EXP  /* 5.00[01] compatibility */
2504     incpush(OLDARCHLIB_EXP, FALSE);
2505 #endif
2506
2507     if (!tainting)
2508         incpush(".", FALSE);
2509 }
2510
2511 #if defined(DOSISH)
2512 #    define PERLLIB_SEP ';'
2513 #else
2514 #  if defined(VMS)
2515 #    define PERLLIB_SEP '|'
2516 #  else
2517 #    define PERLLIB_SEP ':'
2518 #  endif
2519 #endif
2520 #ifndef PERLLIB_MANGLE
2521 #  define PERLLIB_MANGLE(s,n) (s)
2522 #endif
2523
2524 static void
2525 incpush(p, addsubdirs)
2526 char *p;
2527 int addsubdirs;
2528 {
2529     SV *subdir = Nullsv;
2530     static char *archpat_auto;
2531
2532     if (!p)
2533         return;
2534
2535     if (addsubdirs) {
2536         subdir = newSV(0);
2537         if (!archpat_auto) {
2538             STRLEN len = (sizeof(ARCHNAME) + strlen(patchlevel)
2539                           + sizeof("//auto"));
2540             New(55, archpat_auto, len, char);
2541             sprintf(archpat_auto, "/%s/%s/auto", ARCHNAME, patchlevel);
2542 #ifdef VMS
2543         for (len = sizeof(ARCHNAME) + 2;
2544              archpat_auto[len] != '\0' && archpat_auto[len] != '/'; len++)
2545                 if (archpat_auto[len] == '.') archpat_auto[len] = '_';
2546 #endif
2547         }
2548     }
2549
2550     /* Break at all separators */
2551     while (p && *p) {
2552         SV *libdir = newSV(0);
2553         char *s;
2554
2555         /* skip any consecutive separators */
2556         while ( *p == PERLLIB_SEP ) {
2557             /* Uncomment the next line for PATH semantics */
2558             /* av_push(GvAVn(incgv), newSVpv(".", 1)); */
2559             p++;
2560         }
2561
2562         if ( (s = strchr(p, PERLLIB_SEP)) != Nullch ) {
2563             sv_setpvn(libdir, PERLLIB_MANGLE(p, (STRLEN)(s - p)),
2564                       (STRLEN)(s - p));
2565             p = s + 1;
2566         }
2567         else {
2568             sv_setpv(libdir, PERLLIB_MANGLE(p, 0));
2569             p = Nullch; /* break out */
2570         }
2571
2572         /*
2573          * BEFORE pushing libdir onto @INC we may first push version- and
2574          * archname-specific sub-directories.
2575          */
2576         if (addsubdirs) {
2577             struct stat tmpstatbuf;
2578 #ifdef VMS
2579             char *unix;
2580             STRLEN len;
2581
2582             if ((unix = tounixspec_ts(SvPV(libdir,na),Nullch)) != Nullch) {
2583                 len = strlen(unix);
2584                 while (unix[len-1] == '/') len--;  /* Cosmetic */
2585                 sv_usepvn(libdir,unix,len);
2586             }
2587             else
2588                 PerlIO_printf(PerlIO_stderr(),
2589                               "Failed to unixify @INC element \"%s\"\n",
2590                               SvPV(libdir,na));
2591 #endif
2592             /* .../archname/version if -d .../archname/version/auto */
2593             sv_setsv(subdir, libdir);
2594             sv_catpv(subdir, archpat_auto);
2595             if (Stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
2596                   S_ISDIR(tmpstatbuf.st_mode))
2597                 av_push(GvAVn(incgv),
2598                         newSVpv(SvPVX(subdir), SvCUR(subdir) - sizeof "auto"));
2599
2600             /* .../archname if -d .../archname/auto */
2601             sv_insert(subdir, SvCUR(libdir) + sizeof(ARCHNAME),
2602                       strlen(patchlevel) + 1, "", 0);
2603             if (Stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
2604                   S_ISDIR(tmpstatbuf.st_mode))
2605                 av_push(GvAVn(incgv),
2606                         newSVpv(SvPVX(subdir), SvCUR(subdir) - sizeof "auto"));
2607         }
2608
2609         /* finally push this lib directory on the end of @INC */
2610         av_push(GvAVn(incgv), libdir);
2611     }
2612
2613     SvREFCNT_dec(subdir);
2614 }
2615
2616 void
2617 call_list(oldscope, list)
2618 I32 oldscope;
2619 AV* list;
2620 {
2621     line_t oldline = curcop->cop_line;
2622     STRLEN len;
2623     dJMPENV;
2624     int ret;
2625
2626     while (AvFILL(list) >= 0) {
2627         CV *cv = (CV*)av_shift(list);
2628
2629         SAVEFREESV(cv);
2630
2631         JMPENV_PUSH(ret);
2632         switch (ret) {
2633         case 0: {
2634                 SV* atsv = GvSV(errgv);
2635                 PUSHMARK(stack_sp);
2636                 perl_call_sv((SV*)cv, G_EVAL|G_DISCARD);
2637                 (void)SvPV(atsv, len);
2638                 if (len) {
2639                     JMPENV_POP;
2640                     curcop = &compiling;
2641                     curcop->cop_line = oldline;
2642                     if (list == beginav)
2643                         sv_catpv(atsv, "BEGIN failed--compilation aborted");
2644                     else
2645                         sv_catpv(atsv, "END failed--cleanup aborted");
2646                     while (scopestack_ix > oldscope)
2647                         LEAVE;
2648                     croak("%s", SvPVX(atsv));
2649                 }
2650             }
2651             break;
2652         case 1:
2653             STATUS_ALL_FAILURE;
2654             /* FALL THROUGH */
2655         case 2:
2656             /* my_exit() was called */
2657             while (scopestack_ix > oldscope)
2658                 LEAVE;
2659             FREETMPS;
2660             curstash = defstash;
2661             if (endav)
2662                 call_list(oldscope, endav);
2663             JMPENV_POP;
2664             curcop = &compiling;
2665             curcop->cop_line = oldline;
2666             if (statusvalue) {
2667                 if (list == beginav)
2668                     croak("BEGIN failed--compilation aborted");
2669                 else
2670                     croak("END failed--cleanup aborted");
2671             }
2672             my_exit_jump();
2673             /* NOTREACHED */
2674         case 3:
2675             if (!restartop) {
2676                 PerlIO_printf(PerlIO_stderr(), "panic: restartop\n");
2677                 FREETMPS;
2678                 break;
2679             }
2680             JMPENV_POP;
2681             curcop = &compiling;
2682             curcop->cop_line = oldline;
2683             JMPENV_JUMP(3);
2684         }
2685         JMPENV_POP;
2686     }
2687 }
2688
2689 void
2690 my_exit(status)
2691 U32 status;
2692 {
2693     switch (status) {
2694     case 0:
2695         STATUS_ALL_SUCCESS;
2696         break;
2697     case 1:
2698         STATUS_ALL_FAILURE;
2699         break;
2700     default:
2701         STATUS_NATIVE_SET(status);
2702         break;
2703     }
2704     my_exit_jump();
2705 }
2706
2707 void
2708 my_failure_exit()
2709 {
2710 #ifdef VMS
2711     if (vaxc$errno & 1) {
2712         if (STATUS_NATIVE & 1)          /* fortuitiously includes "-1" */
2713             STATUS_NATIVE_SET(44);
2714     }
2715     else {
2716         if (!vaxc$errno && errno)       /* unlikely */
2717             STATUS_NATIVE_SET(44);
2718         else
2719             STATUS_NATIVE_SET(vaxc$errno);
2720     }
2721 #else
2722     if (errno & 255)
2723         STATUS_POSIX_SET(errno);
2724     else if (STATUS_POSIX == 0)
2725         STATUS_POSIX_SET(255);
2726 #endif
2727     my_exit_jump();
2728 }
2729
2730 static void
2731 my_exit_jump()
2732 {
2733     register CONTEXT *cx;
2734     I32 gimme;
2735     SV **newsp;
2736
2737     if (e_tmpname) {
2738         if (e_fp) {
2739             PerlIO_close(e_fp);
2740             e_fp = Nullfp;
2741         }
2742         (void)UNLINK(e_tmpname);
2743         Safefree(e_tmpname);
2744         e_tmpname = Nullch;
2745     }
2746
2747     if (cxstack_ix >= 0) {
2748         if (cxstack_ix > 0)
2749             dounwind(0);
2750         POPBLOCK(cx,curpm);
2751         LEAVE;
2752     }
2753
2754     JMPENV_JUMP(2);
2755 }