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