perl.c

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