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