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