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