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