perl.c

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