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_magic(hv, envgv, 'E');
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         for (; *env; env++) {
2293             if (!(s = strchr(*env,'=')))
2294                 continue;
2295             *s++ = '\0';
2296             sv = newSVpv(s--,0);
2297             (void)hv_store(hv, *env, s - *env, sv, 0);
2298             *s = '=';
2299         }
2300 #endif
2301 #ifdef DYNAMIC_ENV_FETCH
2302         HvNAME(hv) = savepv(ENV_HV_NAME);
2303 #endif
2304     }
2305     TAINT_NOT;
2306     if (tmpgv = gv_fetchpv("$",TRUE, SVt_PV))
2307         sv_setiv(GvSV(tmpgv), (IV)getpid());
2308 }
2309
2310 static void
2311 init_perllib()
2312 {
2313     char *s;
2314     if (!tainting) {
2315 #ifndef VMS
2316         s = getenv("PERL5LIB");
2317         if (s)
2318             incpush(s, TRUE);
2319         else
2320             incpush(getenv("PERLLIB"), FALSE);
2321 #else /* VMS */
2322         /* Treat PERL5?LIB as a possible search list logical name -- the
2323          * "natural" VMS idiom for a Unix path string.  We allow each
2324          * element to be a set of |-separated directories for compatibility.
2325          */
2326         char buf[256];
2327         int idx = 0;
2328         if (my_trnlnm("PERL5LIB",buf,0))
2329             do { incpush(buf,TRUE); } while (my_trnlnm("PERL5LIB",buf,++idx));
2330         else
2331             while (my_trnlnm("PERLLIB",buf,idx++)) incpush(buf,FALSE);
2332 #endif /* VMS */
2333     }
2334
2335 /* Use the ~-expanded versions of APPLIB (undocumented),
2336     ARCHLIB PRIVLIB SITEARCH SITELIB and OLDARCHLIB
2337 */
2338 #ifdef APPLLIB_EXP
2339     incpush(APPLLIB_EXP, FALSE);
2340 #endif
2341
2342 #ifdef ARCHLIB_EXP
2343     incpush(ARCHLIB_EXP, FALSE);
2344 #endif
2345 #ifndef PRIVLIB_EXP
2346 #define PRIVLIB_EXP "/usr/local/lib/perl5:/usr/local/lib/perl"
2347 #endif
2348     incpush(PRIVLIB_EXP, FALSE);
2349
2350 #ifdef SITEARCH_EXP
2351     incpush(SITEARCH_EXP, FALSE);
2352 #endif
2353 #ifdef SITELIB_EXP
2354     incpush(SITELIB_EXP, FALSE);
2355 #endif
2356 #ifdef OLDARCHLIB_EXP  /* 5.00[01] compatibility */
2357     incpush(OLDARCHLIB_EXP, FALSE);
2358 #endif
2359
2360     if (!tainting)
2361         incpush(".", FALSE);
2362 }
2363
2364 #if defined(DOSISH)
2365 #    define PERLLIB_SEP ';'
2366 #else
2367 #  if defined(VMS)
2368 #    define PERLLIB_SEP '|'
2369 #  else
2370 #    define PERLLIB_SEP ':'
2371 #  endif
2372 #endif
2373 #ifndef PERLLIB_MANGLE
2374 #  define PERLLIB_MANGLE(s,n) (s)
2375 #endif
2376
2377 static void
2378 incpush(p, addsubdirs)
2379 char *p;
2380 int addsubdirs;
2381 {
2382     SV *subdir = Nullsv;
2383     static char *archpat_auto;
2384
2385     if (!p)
2386         return;
2387
2388     if (addsubdirs) {
2389         subdir = newSV(0);
2390         if (!archpat_auto) {
2391             STRLEN len = (sizeof(ARCHNAME) + strlen(patchlevel)
2392                           + sizeof("//auto"));
2393             New(55, archpat_auto, len, char);
2394             sprintf(archpat_auto, "/%s/%s/auto", ARCHNAME, patchlevel);
2395 #ifdef VMS
2396         for (len = sizeof(ARCHNAME) + 2;
2397              archpat_auto[len] != '\0' && archpat_auto[len] != '/'; len++)
2398                 if (archpat_auto[len] == '.') archpat_auto[len] = '_';
2399 #endif
2400         }
2401     }
2402
2403     /* Break at all separators */
2404     while (p && *p) {
2405         SV *libdir = newSV(0);
2406         char *s;
2407
2408         /* skip any consecutive separators */
2409         while ( *p == PERLLIB_SEP ) {
2410             /* Uncomment the next line for PATH semantics */
2411             /* av_push(GvAVn(incgv), newSVpv(".", 1)); */
2412             p++;
2413         }
2414
2415         if ( (s = strchr(p, PERLLIB_SEP)) != Nullch ) {
2416             sv_setpvn(libdir, PERLLIB_MANGLE(p, (STRLEN)(s - p)),
2417                       (STRLEN)(s - p));
2418             p = s + 1;
2419         }
2420         else {
2421             sv_setpv(libdir, PERLLIB_MANGLE(p, 0));
2422             p = Nullch; /* break out */
2423         }
2424
2425         /*
2426          * BEFORE pushing libdir onto @INC we may first push version- and
2427          * archname-specific sub-directories.
2428          */
2429         if (addsubdirs) {
2430             struct stat tmpstatbuf;
2431 #ifdef VMS
2432             char *unix;
2433             STRLEN len;
2434
2435             if ((unix = tounixspec_ts(SvPV(libdir,na),Nullch)) != Nullch) {
2436                 len = strlen(unix);
2437                 while (unix[len-1] == '/') len--;  /* Cosmetic */
2438                 sv_usepvn(libdir,unix,len);
2439             }
2440             else
2441                 PerlIO_printf(PerlIO_stderr(),
2442                               "Failed to unixify @INC element \"%s\"\n",
2443                               SvPV(libdir,na));
2444 #endif
2445             /* .../archname/version if -d .../archname/version/auto */
2446             sv_setsv(subdir, libdir);
2447             sv_catpv(subdir, archpat_auto);
2448             if (Stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
2449                   S_ISDIR(tmpstatbuf.st_mode))
2450                 av_push(GvAVn(incgv),
2451                         newSVpv(SvPVX(subdir), SvCUR(subdir) - sizeof "auto"));
2452
2453             /* .../archname if -d .../archname/auto */
2454             sv_insert(subdir, SvCUR(libdir) + sizeof(ARCHNAME),
2455                       strlen(patchlevel) + 1, "", 0);
2456             if (Stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
2457                   S_ISDIR(tmpstatbuf.st_mode))
2458                 av_push(GvAVn(incgv),
2459                         newSVpv(SvPVX(subdir), SvCUR(subdir) - sizeof "auto"));
2460         }
2461
2462         /* finally push this lib directory on the end of @INC */
2463         av_push(GvAVn(incgv), libdir);
2464     }
2465
2466     SvREFCNT_dec(subdir);
2467 }
2468
2469 void
2470 call_list(oldscope, list)
2471 I32 oldscope;
2472 AV* list;
2473 {
2474     line_t oldline = curcop->cop_line;
2475     STRLEN len;
2476     dJMPENV;
2477     int ret;
2478
2479     while (AvFILL(list) >= 0) {
2480         CV *cv = (CV*)av_shift(list);
2481
2482         SAVEFREESV(cv);
2483
2484         JMPENV_PUSH(ret);
2485         switch (ret) {
2486         case 0: {
2487                 SV* atsv = GvSV(errgv);
2488                 PUSHMARK(stack_sp);
2489                 perl_call_sv((SV*)cv, G_EVAL|G_DISCARD);
2490                 (void)SvPV(atsv, len);
2491                 if (len) {
2492                     JMPENV_POP;
2493                     curcop = &compiling;
2494                     curcop->cop_line = oldline;
2495                     if (list == beginav)
2496                         sv_catpv(atsv, "BEGIN failed--compilation aborted");
2497                     else
2498                         sv_catpv(atsv, "END failed--cleanup aborted");
2499                     while (scopestack_ix > oldscope)
2500                         LEAVE;
2501                     croak("%s", SvPVX(atsv));
2502                 }
2503             }
2504             break;
2505         case 1:
2506             STATUS_ALL_FAILURE;
2507             /* FALL THROUGH */
2508         case 2:
2509             /* my_exit() was called */
2510             while (scopestack_ix > oldscope)
2511                 LEAVE;
2512             curstash = defstash;
2513             if (endav)
2514                 call_list(oldscope, endav);
2515             FREETMPS;
2516             JMPENV_POP;
2517             curcop = &compiling;
2518             curcop->cop_line = oldline;
2519             if (statusvalue) {
2520                 if (list == beginav)
2521                     croak("BEGIN failed--compilation aborted");
2522                 else
2523                     croak("END failed--cleanup aborted");
2524             }
2525             my_exit_jump();
2526             /* NOTREACHED */
2527         case 3:
2528             if (!restartop) {
2529                 PerlIO_printf(PerlIO_stderr(), "panic: restartop\n");
2530                 FREETMPS;
2531                 break;
2532             }
2533             JMPENV_POP;
2534             curcop = &compiling;
2535             curcop->cop_line = oldline;
2536             JMPENV_JUMP(3);
2537         }
2538         JMPENV_POP;
2539     }
2540 }
2541
2542 void
2543 my_exit(status)
2544 U32 status;
2545 {
2546     switch (status) {
2547     case 0:
2548         STATUS_ALL_SUCCESS;
2549         break;
2550     case 1:
2551         STATUS_ALL_FAILURE;
2552         break;
2553     default:
2554         STATUS_NATIVE_SET(status);
2555         break;
2556     }
2557     my_exit_jump();
2558 }
2559
2560 void
2561 my_failure_exit()
2562 {
2563 #ifdef VMS
2564     if (vaxc$errno & 1) {
2565         if (STATUS_NATIVE & 1)          /* fortuitiously includes "-1" */
2566             STATUS_NATIVE_SET(44);
2567     }
2568     else {
2569         if (!vaxc$errno && errno)       /* unlikely */
2570             STATUS_NATIVE_SET(44);
2571         else
2572             STATUS_NATIVE_SET(vaxc$errno);
2573     }
2574 #else
2575     if (errno & 255)
2576         STATUS_POSIX_SET(errno);
2577     else if (STATUS_POSIX == 0)
2578         STATUS_POSIX_SET(255);
2579 #endif
2580     my_exit_jump();
2581 }
2582
2583 static void
2584 my_exit_jump()
2585 {
2586     register CONTEXT *cx;
2587     I32 gimme;
2588     SV **newsp;
2589
2590     if (e_tmpname) {
2591         if (e_fp) {
2592             PerlIO_close(e_fp);
2593             e_fp = Nullfp;
2594         }
2595         (void)UNLINK(e_tmpname);
2596         Safefree(e_tmpname);
2597         e_tmpname = Nullch;
2598     }
2599
2600     if (cxstack_ix >= 0) {
2601         if (cxstack_ix > 0)
2602             dounwind(0);
2603         POPBLOCK(cx,curpm);
2604         LEAVE;
2605     }
2606
2607     JMPENV_JUMP(2);
2608 }