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