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