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