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