perl.c

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