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