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;
 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     Zero(&myop, 1, LOGOP);
 963     if (flags & G_NOARGS) {
 964         PUSHMARK(sp);
 965     }
 966     else
 967         myop.op_flags |= OPf_STACKED;
 968     myop.op_next = Nullop;
 969     myop.op_flags |= OPf_KNOW;
 970     if (flags & G_ARRAY)
 971         myop.op_flags |= OPf_LIST;
 972     SAVESPTR(op);
 973     op = (OP*)&myop;
 974
 975     EXTEND(stack_sp, 1);
 976     *++stack_sp = sv;
 977     oldmark = TOPMARK;
 978     oldscope = scopestack_ix;
 979
 980     if (perldb && curstash != debstash
 981            /* Handle first BEGIN of -d. */
 982           && (DBcv || (DBcv = GvCV(DBsub)))
 983            /* Try harder, since this may have been a sighandler, thus
 984             * curstash may be meaningless. */
 985           && (SvTYPE(sv) != SVt_PVCV || CvSTASH((CV*)sv) != debstash))
 986         op->op_private |= OPpENTERSUB_DB;
 987
 988     if (flags & G_EVAL) {
 989         Copy(top_env, oldtop, 1, Sigjmp_buf);
 990
 991         cLOGOP->op_other = op;
 992         markstack_ptr--;
 993         /* we're trying to emulate pp_entertry() here */
 994         {
 995             register CONTEXT *cx;
 996             I32 gimme = GIMME;
 997
 998             ENTER;
 999             SAVETMPS;
1000
1001             push_return(op->op_next);
1002             PUSHBLOCK(cx, CXt_EVAL, stack_sp);
1003             PUSHEVAL(cx, 0, 0);
1004             eval_root = op;             /* Only needed so that goto works right. */
1005
1006             in_eval = 1;
1007             if (flags & G_KEEPERR)
1008                 in_eval |= 4;
1009             else
1010                 sv_setpv(GvSV(errgv),"");
1011         }
1012         markstack_ptr++;
1013
1014     restart:
1015         switch (Sigsetjmp(top_env,1)) {
1016         case 0:
1017             break;
1018         case 1:
1019             STATUS_ALL_FAILURE;
1020             /* FALL THROUGH */
1021         case 2:
1022             /* my_exit() was called */
1023             curstash = defstash;
1024             FREETMPS;
1025             Copy(oldtop, top_env, 1, Sigjmp_buf);
1026             if (statusvalue)
1027                 croak("Callback called exit");
1028             my_exit_jump();
1029             /* NOTREACHED */
1030         case 3:
1031             if (restartop) {
1032                 op = restartop;
1033                 restartop = 0;
1034                 goto restart;
1035             }
1036             stack_sp = stack_base + oldmark;
1037             if (flags & G_ARRAY)
1038                 retval = 0;
1039             else {
1040                 retval = 1;
1041                 *++stack_sp = &sv_undef;
1042             }
1043             goto cleanup;
1044         }
1045     }
1046
1047     if (op == (OP*)&myop)
1048         op = pp_entersub();
1049     if (op)
1050         runops();
1051     retval = stack_sp - (stack_base + oldmark);
1052     if ((flags & G_EVAL) && !(flags & G_KEEPERR))
1053         sv_setpv(GvSV(errgv),"");
1054
1055   cleanup:
1056     if (flags & G_EVAL) {
1057         if (scopestack_ix > oldscope) {
1058             SV **newsp;
1059             PMOP *newpm;
1060             I32 gimme;
1061             register CONTEXT *cx;
1062             I32 optype;
1063
1064             POPBLOCK(cx,newpm);
1065             POPEVAL(cx);
1066             pop_return();
1067             curpm = newpm;
1068             LEAVE;
1069         }
1070         Copy(oldtop, top_env, 1, Sigjmp_buf);
1071     }
1072     if (flags & G_DISCARD) {
1073         stack_sp = stack_base + oldmark;
1074         retval = 0;
1075         FREETMPS;
1076         LEAVE;
1077     }
1078     return retval;
1079 }
1080
1081 /* Eval a string. The G_EVAL flag is always assumed. */
1082
1083 I32
1084 perl_eval_sv(sv, flags)
1085 SV* sv;
1086 I32 flags;              /* See G_* flags in cop.h */
1087 {
1088     UNOP myop;          /* fake syntax tree node */
1089     SV** sp = stack_sp;
1090     I32 oldmark = sp - stack_base;
1091     I32 retval;
1092     Sigjmp_buf oldtop;
1093     I32 oldscope;
1094
1095     if (flags & G_DISCARD) {
1096         ENTER;
1097         SAVETMPS;
1098     }
1099
1100     SAVESPTR(op);
1101     op = (OP*)&myop;
1102     Zero(op, 1, UNOP);
1103     EXTEND(stack_sp, 1);
1104     *++stack_sp = sv;
1105     oldscope = scopestack_ix;
1106
1107     if (!(flags & G_NOARGS))
1108         myop.op_flags = OPf_STACKED;
1109     myop.op_next = Nullop;
1110     myop.op_type = OP_ENTEREVAL;
1111     myop.op_flags |= OPf_KNOW;
1112     if (flags & G_KEEPERR)
1113         myop.op_flags |= OPf_SPECIAL;
1114     if (flags & G_ARRAY)
1115         myop.op_flags |= OPf_LIST;
1116
1117     Copy(top_env, oldtop, 1, Sigjmp_buf);
1118
1119 restart:
1120     switch (Sigsetjmp(top_env,1)) {
1121     case 0:
1122         break;
1123     case 1:
1124         STATUS_ALL_FAILURE;
1125         /* FALL THROUGH */
1126     case 2:
1127         /* my_exit() was called */
1128         curstash = defstash;
1129         FREETMPS;
1130         Copy(oldtop, top_env, 1, Sigjmp_buf);
1131         if (statusvalue)
1132             croak("Callback called exit");
1133         my_exit_jump();
1134         /* NOTREACHED */
1135     case 3:
1136         if (restartop) {
1137             op = restartop;
1138             restartop = 0;
1139             goto restart;
1140         }
1141         stack_sp = stack_base + oldmark;
1142         if (flags & G_ARRAY)
1143             retval = 0;
1144         else {
1145             retval = 1;
1146             *++stack_sp = &sv_undef;
1147         }
1148         goto cleanup;
1149     }
1150
1151     if (op == (OP*)&myop)
1152         op = pp_entereval();
1153     if (op)
1154         runops();
1155     retval = stack_sp - (stack_base + oldmark);
1156     if (!(flags & G_KEEPERR))
1157         sv_setpv(GvSV(errgv),"");
1158
1159   cleanup:
1160     Copy(oldtop, top_env, 1, Sigjmp_buf);
1161     if (flags & G_DISCARD) {
1162         stack_sp = stack_base + oldmark;
1163         retval = 0;
1164         FREETMPS;
1165         LEAVE;
1166     }
1167     return retval;
1168 }
1169
1170 /* Require a module. */
1171
1172 void
1173 perl_require_pv(pv)
1174 char* pv;
1175 {
1176     SV* sv = sv_newmortal();
1177     sv_setpv(sv, "require '");
1178     sv_catpv(sv, pv);
1179     sv_catpv(sv, "'");
1180     perl_eval_sv(sv, G_DISCARD);
1181 }
1182
1183 void
1184 magicname(sym,name,namlen)
1185 char *sym;
1186 char *name;
1187 I32 namlen;
1188 {
1189     register GV *gv;
1190
1191     if (gv = gv_fetchpv(sym,TRUE, SVt_PV))
1192         sv_magic(GvSV(gv), (SV*)gv, 0, name, namlen);
1193 }
1194
1195 static void
1196 usage(name)             /* XXX move this out into a module ? */
1197 char *name;
1198 {
1199     /* This message really ought to be max 23 lines.
1200      * Removed -h because the user already knows that opton. Others? */
1201     printf("\nUsage: %s [switches] [--] [programfile] [arguments]", name);
1202     printf("\n  -0[octal]       specify record separator (\\0, if no argument)");
1203     printf("\n  -a              autosplit mode with -n or -p (splits $_ into @F)");
1204     printf("\n  -c              check syntax only (runs BEGIN and END blocks)");
1205     printf("\n  -d[:debugger]   run scripts under debugger");
1206     printf("\n  -D[number/list] set debugging flags (argument is a bit mask or flags)");
1207     printf("\n  -e 'command'    one line of script. Several -e's allowed. Omit [programfile].");
1208     printf("\n  -F/pattern/     split() pattern for autosplit (-a). The //'s are optional.");
1209     printf("\n  -i[extension]   edit <> files in place (make backup if extension supplied)");
1210     printf("\n  -Idirectory     specify @INC/#include directory (may be used more then once)");
1211     printf("\n  -l[octal]       enable line ending processing, specifies line teminator");
1212     printf("\n  -[mM][-]module.. executes `use/no module...' before executing your script.");
1213     printf("\n  -n              assume 'while (<>) { ... }' loop arround your script");
1214     printf("\n  -p              assume loop like -n but print line also like sed");
1215     printf("\n  -P              run script through C preprocessor before compilation");
1216     printf("\n  -s              enable some switch parsing for switches after script name");
1217     printf("\n  -S              look for the script using PATH environment variable");
1218     printf("\n  -T              turn on tainting checks");
1219     printf("\n  -u              dump core after parsing script");
1220     printf("\n  -U              allow unsafe operations");
1221     printf("\n  -v              print version number and patchlevel of perl");
1222     printf("\n  -V[:variable]   print perl configuration information");
1223     printf("\n  -w              TURN WARNINGS ON FOR COMPILATION OF YOUR SCRIPT.");
1224     printf("\n  -x[directory]   strip off text before #!perl line and perhaps cd to directory\n");
1225 }
1226
1227 /* This routine handles any switches that can be given during run */
1228
1229 char *
1230 moreswitches(s)
1231 char *s;
1232 {
1233     I32 numlen;
1234     U32 rschar;
1235
1236     switch (*s) {
1237     case '0':
1238         rschar = scan_oct(s, 4, &numlen);
1239         SvREFCNT_dec(nrs);
1240         if (rschar & ~((U8)~0))
1241             nrs = &sv_undef;
1242         else if (!rschar && numlen >= 2)
1243             nrs = newSVpv("", 0);
1244         else {
1245             char ch = rschar;
1246             nrs = newSVpv(&ch, 1);
1247         }
1248         return s + numlen;
1249     case 'F':
1250         minus_F = TRUE;
1251         splitstr = savepv(s + 1);
1252         s += strlen(s);
1253         return s;
1254     case 'a':
1255         minus_a = TRUE;
1256         s++;
1257         return s;
1258     case 'c':
1259         minus_c = TRUE;
1260         s++;
1261         return s;
1262     case 'd':
1263         forbid_setid("-d");
1264         s++;
1265         if (*s == ':' || *s == '=')  {
1266             sprintf(buf, "use Devel::%s;", ++s);
1267             s += strlen(s);
1268             my_setenv("PERL5DB",buf);
1269         }
1270         if (!perldb) {
1271             perldb = TRUE;
1272             init_debugger();
1273         }
1274         return s;
1275     case 'D':
1276 #ifdef DEBUGGING
1277         forbid_setid("-D");
1278         if (isALPHA(s[1])) {
1279             static char debopts[] = "psltocPmfrxuLHXD";
1280             char *d;
1281
1282             for (s++; *s && (d = strchr(debopts,*s)); s++)
1283                 debug |= 1 << (d - debopts);
1284         }
1285         else {
1286             debug = atoi(s+1);
1287             for (s++; isDIGIT(*s); s++) ;
1288         }
1289         debug |= 0x80000000;
1290 #else
1291         warn("Recompile perl with -DDEBUGGING to use -D switch\n");
1292         for (s++; isALNUM(*s); s++) ;
1293 #endif
1294         /*SUPPRESS 530*/
1295         return s;
1296     case 'h':
1297         usage(origargv[0]);
1298         exit(0);
1299     case 'i':
1300         if (inplace)
1301             Safefree(inplace);
1302         inplace = savepv(s+1);
1303         /*SUPPRESS 530*/
1304         for (s = inplace; *s && !isSPACE(*s); s++) ;
1305         *s = '\0';
1306         break;
1307     case 'I':
1308         forbid_setid("-I");
1309         if (*++s) {
1310             char *e, *p;
1311             for (e = s; *e && !isSPACE(*e); e++) ;
1312             p = savepvn(s, e-s);
1313             incpush(p, TRUE);
1314             Safefree(p);
1315             if (*e)
1316                 return e;
1317         }
1318         else
1319             croak("No space allowed after -I");
1320         break;
1321     case 'l':
1322         minus_l = TRUE;
1323         s++;
1324         if (ors)
1325             Safefree(ors);
1326         if (isDIGIT(*s)) {
1327             ors = savepv("\n");
1328             orslen = 1;
1329             *ors = scan_oct(s, 3 + (*s == '0'), &numlen);
1330             s += numlen;
1331         }
1332         else {
1333             if (RsPARA(nrs)) {
1334                 ors = "\n\n";
1335                 orslen = 2;
1336             }
1337             else
1338                 ors = SvPV(nrs, orslen);
1339             ors = savepvn(ors, orslen);
1340         }
1341         return s;
1342     case 'M':
1343         forbid_setid("-M");     /* XXX ? */
1344         /* FALL THROUGH */
1345     case 'm':
1346         forbid_setid("-m");     /* XXX ? */
1347         if (*++s) {
1348             char *start;
1349             char *use = "use ";
1350             /* -M-foo == 'no foo'       */
1351             if (*s == '-') { use = "no "; ++s; }
1352             Sv = newSVpv(use,0);
1353             start = s;
1354             /* We allow -M'Module qw(Foo Bar)'  */
1355             while(isALNUM(*s) || *s==':') ++s;
1356             if (*s != '=') {
1357                 sv_catpv(Sv, start);
1358                 if (*(start-1) == 'm') {
1359                     if (*s != '\0')
1360                         croak("Can't use '%c' after -mname", *s);
1361                     sv_catpv( Sv, " ()");
1362                 }
1363             } else {
1364                 sv_catpvn(Sv, start, s-start);
1365                 sv_catpv(Sv, " split(/,/,q{");
1366                 sv_catpv(Sv, ++s);
1367                 sv_catpv(Sv,    "})");
1368             }
1369             s += strlen(s);
1370             if (preambleav == NULL)
1371                 preambleav = newAV();
1372             av_push(preambleav, Sv);
1373         }
1374         else
1375             croak("No space allowed after -%c", *(s-1));
1376         return s;
1377     case 'n':
1378         minus_n = TRUE;
1379         s++;
1380         return s;
1381     case 'p':
1382         minus_p = TRUE;
1383         s++;
1384         return s;
1385     case 's':
1386         forbid_setid("-s");
1387         doswitches = TRUE;
1388         s++;
1389         return s;
1390     case 'T':
1391         if (!tainting)
1392             croak("Too late for \"-T\" option (try putting it first)");
1393         s++;
1394         return s;
1395     case 'u':
1396         do_undump = TRUE;
1397         s++;
1398         return s;
1399     case 'U':
1400         unsafe = TRUE;
1401         s++;
1402         return s;
1403     case 'v':
1404 #if defined(SUBVERSION) && SUBVERSION > 0
1405         printf("\nThis is perl, version 5.%03d_%02d", PATCHLEVEL, SUBVERSION);
1406 #else
1407         printf("\nThis is perl, version %s",patchlevel);
1408 #endif
1409
1410         printf("\n\nCopyright 1987-1997, Larry Wall\n");
1411 #ifdef MSDOS
1412         printf("\n\nMS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n");
1413 #endif
1414 #ifdef DJGPP
1415         printf("djgpp v2 port (jpl5003c) by Hirofumi Watanabe, 1996\n");
1416 #endif
1417 #ifdef OS2
1418         printf("\n\nOS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n"
1419             "Version 5 port Copyright (c) 1994-1996, Andreas Kaiser, Ilya Zakharevich\n");
1420 #endif
1421 #ifdef atarist
1422         printf("atariST series port, ++jrb  bammi@cadence.com\n");
1423 #endif
1424         printf("\n\
1425 Perl may be copied only under the terms of either the Artistic License or the\n\
1426 GNU General Public License, which may be found in the Perl 5.0 source kit.\n\n");
1427         exit(0);
1428     case 'w':
1429         dowarn = TRUE;
1430         s++;
1431         return s;
1432     case '*':
1433     case ' ':
1434         if (s[1] == '-')        /* Additional switches on #! line. */
1435             return s+2;
1436         break;
1437     case '-':
1438     case 0:
1439     case '\n':
1440     case '\t':
1441         break;
1442 #ifdef ALTERNATE_SHEBANG
1443     case 'S':                   /* OS/2 needs -S on "extproc" line. */
1444         break;
1445 #endif
1446     case 'P':
1447         if (preprocess)
1448             return s+1;
1449         /* FALL THROUGH */
1450     default:
1451         croak("Can't emulate -%.1s on #! line",s);
1452     }
1453     return Nullch;
1454 }
1455
1456 /* compliments of Tom Christiansen */
1457
1458 /* unexec() can be found in the Gnu emacs distribution */
1459
1460 void
1461 my_unexec()
1462 {
1463 #ifdef UNEXEC
1464     int    status;
1465     extern int etext;
1466
1467     sprintf (buf, "%s.perldump", origfilename);
1468     sprintf (tokenbuf, "%s/perl", BIN);
1469
1470     status = unexec(buf, tokenbuf, &etext, sbrk(0), 0);
1471     if (status)
1472         PerlIO_printf(PerlIO_stderr(), "unexec of %s into %s failed!\n", tokenbuf, buf);
1473     exit(status);
1474 #else
1475 #  ifdef VMS
1476 #    include <lib$routines.h>
1477      lib$signal(SS$_DEBUG);  /* ssdef.h #included from vmsish.h */
1478 #  else
1479     ABORT();            /* for use with undump */
1480 #  endif
1481 #endif
1482 }
1483
1484 static void
1485 init_main_stash()
1486 {
1487     GV *gv;
1488
1489     /* Note that strtab is a rather special HV.  Assumptions are made
1490        about not iterating on it, and not adding tie magic to it.
1491        It is properly deallocated in perl_destruct() */
1492     strtab = newHV();
1493     HvSHAREKEYS_off(strtab);                    /* mandatory */
1494     Newz(506,((XPVHV*)SvANY(strtab))->xhv_array,
1495          sizeof(HE*) * (((XPVHV*)SvANY(strtab))->xhv_max + 1), char);
1496
1497     curstash = defstash = newHV();
1498     curstname = newSVpv("main",4);
1499     gv = gv_fetchpv("main::",TRUE, SVt_PVHV);
1500     SvREFCNT_dec(GvHV(gv));
1501     GvHV(gv) = (HV*)SvREFCNT_inc(defstash);
1502     SvREADONLY_on(gv);
1503     HvNAME(defstash) = savepv("main");
1504     incgv = gv_HVadd(gv_AVadd(gv_fetchpv("INC",TRUE, SVt_PVAV)));
1505     GvMULTI_on(incgv);
1506     defgv = gv_fetchpv("_",TRUE, SVt_PVAV);
1507     errgv = gv_HVadd(gv_fetchpv("@", TRUE, SVt_PV));
1508     GvMULTI_on(errgv);
1509     sv_setpvn(GvSV(errgv), "", 0);
1510     curstash = defstash;
1511     compiling.cop_stash = defstash;
1512     debstash = GvHV(gv_fetchpv("DB::", GV_ADDMULTI, SVt_PVHV));
1513     /* We must init $/ before switches are processed. */
1514     sv_setpvn(GvSV(gv_fetchpv("/", TRUE, SVt_PV)), "\n", 1);
1515 }
1516
1517 #ifdef CAN_PROTOTYPE
1518 static void
1519 open_script(char *scriptname, bool dosearch, SV *sv)
1520 #else
1521 static void
1522 open_script(scriptname,dosearch,sv)
1523 char *scriptname;
1524 bool dosearch;
1525 SV *sv;
1526 #endif
1527 {
1528     char *xfound = Nullch;
1529     char *xfailed = Nullch;
1530     register char *s;
1531     I32 len;
1532     int retval;
1533 #if defined(DOSISH) && !defined(OS2) && !defined(atarist)
1534 #define SEARCH_EXTS ".bat", ".cmd", NULL
1535 #endif
1536 #ifdef VMS
1537 #  define SEARCH_EXTS ".pl", ".com", NULL
1538 #endif
1539     /* additional extensions to try in each dir if scriptname not found */
1540 #ifdef SEARCH_EXTS
1541     char *ext[] = { SEARCH_EXTS };
1542     int extidx = (strchr(scriptname,'.')) ? -1 : 0; /* has ext already */
1543 #endif
1544
1545 #ifdef VMS
1546     if (dosearch) {
1547         int hasdir, idx = 0, deftypes = 1;
1548
1549         hasdir = (strpbrk(scriptname,":[</") != Nullch) ;
1550         /* The first time through, just add SEARCH_EXTS to whatever we
1551          * already have, so we can check for default file types. */
1552         while (deftypes || (!hasdir && my_trnlnm("DCL$PATH",tokenbuf,idx++)) ) {
1553             if (deftypes) { deftypes = 0; *tokenbuf = '\0'; }
1554             strcat(tokenbuf,scriptname);
1555 #else  /* !VMS */
1556     if (dosearch && !strchr(scriptname, '/') && (s = getenv("PATH"))) {
1557
1558         bufend = s + strlen(s);
1559         while (*s) {
1560 #ifndef DOSISH
1561             s = cpytill(tokenbuf,s,bufend,':',&len);
1562 #else
1563 #ifdef atarist
1564             for (len = 0; *s && *s != ',' && *s != ';'; tokenbuf[len++] = *s++);
1565             tokenbuf[len] = '\0';
1566 #else
1567             for (len = 0; *s && *s != ';'; tokenbuf[len++] = *s++);
1568             tokenbuf[len] = '\0';
1569 #endif
1570 #endif
1571             if (*s)
1572                 s++;
1573 #ifndef DOSISH
1574             if (len && tokenbuf[len-1] != '/')
1575 #else
1576 #ifdef atarist
1577             if (len && ((tokenbuf[len-1] != '\\') && (tokenbuf[len-1] != '/')))
1578 #else
1579             if (len && tokenbuf[len-1] != '\\')
1580 #endif
1581 #endif
1582                 (void)strcat(tokenbuf+len,"/");
1583             (void)strcat(tokenbuf+len,scriptname);
1584 #endif  /* !VMS */
1585
1586 #ifdef SEARCH_EXTS
1587             len = strlen(tokenbuf);
1588             if (extidx > 0)     /* reset after previous loop */
1589                 extidx = 0;
1590             do {
1591 #endif
1592                 DEBUG_p(PerlIO_printf(Perl_debug_log, "Looking for %s\n",tokenbuf));
1593                 retval = Stat(tokenbuf,&statbuf);
1594 #ifdef SEARCH_EXTS
1595             } while (  retval < 0               /* not there */
1596                     && extidx>=0 && ext[extidx] /* try an extension? */
1597                     && strcpy(tokenbuf+len, ext[extidx++])
1598                 );
1599 #endif
1600             if (retval < 0)
1601                 continue;
1602             if (S_ISREG(statbuf.st_mode)
1603              && cando(S_IRUSR,TRUE,&statbuf) && cando(S_IXUSR,TRUE,&statbuf)) {
1604                 xfound = tokenbuf;              /* bingo! */
1605                 break;
1606             }
1607             if (!xfailed)
1608                 xfailed = savepv(tokenbuf);
1609         }
1610         if (!xfound)
1611             croak("Can't execute %s", xfailed ? xfailed : scriptname );
1612         if (xfailed)
1613             Safefree(xfailed);
1614         scriptname = xfound;
1615     }
1616
1617     if (strnEQ(scriptname, "/dev/fd/", 8) && isDIGIT(scriptname[8]) ) {
1618         char *s = scriptname + 8;
1619         fdscript = atoi(s);
1620         while (isDIGIT(*s))
1621             s++;
1622         if (*s)
1623             scriptname = s + 1;
1624     }
1625     else
1626         fdscript = -1;
1627     origfilename = savepv(e_tmpname ? "-e" : scriptname);
1628     curcop->cop_filegv = gv_fetchfile(origfilename);
1629     if (strEQ(origfilename,"-"))
1630         scriptname = "";
1631     if (fdscript >= 0) {
1632         rsfp = PerlIO_fdopen(fdscript,"r");
1633 #if defined(HAS_FCNTL) && defined(F_SETFD)
1634         if (rsfp)
1635             fcntl(PerlIO_fileno(rsfp),F_SETFD,1);  /* ensure close-on-exec */
1636 #endif
1637     }
1638     else if (preprocess) {
1639         char *cpp = CPPSTDIN;
1640
1641         if (strEQ(cpp,"cppstdin"))
1642             sprintf(tokenbuf, "%s/%s", SCRIPTDIR, cpp);
1643         else
1644             sprintf(tokenbuf, "%s", cpp);
1645         sv_catpv(sv,"-I");
1646         sv_catpv(sv,PRIVLIB_EXP);
1647 #ifdef MSDOS
1648         (void)sprintf(buf, "\
1649 sed %s -e \"/^[^#]/b\" \
1650  -e \"/^#[      ]*include[      ]/b\" \
1651  -e \"/^#[      ]*define[       ]/b\" \
1652  -e \"/^#[      ]*if[   ]/b\" \
1653  -e \"/^#[      ]*ifdef[        ]/b\" \
1654  -e \"/^#[      ]*ifndef[       ]/b\" \
1655  -e \"/^#[      ]*else/b\" \
1656  -e \"/^#[      ]*elif[         ]/b\" \
1657  -e \"/^#[      ]*undef[        ]/b\" \
1658  -e \"/^#[      ]*endif/b\" \
1659  -e \"s/^#.*//\" \
1660  %s | %s -C %s %s",
1661           (doextract ? "-e \"1,/^#/d\n\"" : ""),
1662 #else
1663         (void)sprintf(buf, "\
1664 %s %s -e '/^[^#]/b' \
1665  -e '/^#[       ]*include[      ]/b' \
1666  -e '/^#[       ]*define[       ]/b' \
1667  -e '/^#[       ]*if[   ]/b' \
1668  -e '/^#[       ]*ifdef[        ]/b' \
1669  -e '/^#[       ]*ifndef[       ]/b' \
1670  -e '/^#[       ]*else/b' \
1671  -e '/^#[       ]*elif[         ]/b' \
1672  -e '/^#[       ]*undef[        ]/b' \
1673  -e '/^#[       ]*endif/b' \
1674  -e 's/^[       ]*#.*//' \
1675  %s | %s -C %s %s",
1676 #ifdef LOC_SED
1677           LOC_SED,
1678 #else
1679           "sed",
1680 #endif
1681           (doextract ? "-e '1,/^#/d\n'" : ""),
1682 #endif
1683           scriptname, tokenbuf, SvPV(sv, na), CPPMINUS);
1684         doextract = FALSE;
1685 #ifdef IAMSUID                          /* actually, this is caught earlier */
1686         if (euid != uid && !euid) {     /* if running suidperl */
1687 #ifdef HAS_SETEUID
1688             (void)seteuid(uid);         /* musn't stay setuid root */
1689 #else
1690 #ifdef HAS_SETREUID
1691             (void)setreuid((Uid_t)-1, uid);
1692 #else
1693 #ifdef HAS_SETRESUID
1694             (void)setresuid((Uid_t)-1, uid, (Uid_t)-1);
1695 #else
1696             setuid(uid);
1697 #endif
1698 #endif
1699 #endif
1700             if (geteuid() != uid)
1701                 croak("Can't do seteuid!\n");
1702         }
1703 #endif /* IAMSUID */
1704         rsfp = my_popen(buf,"r");
1705     }
1706     else if (!*scriptname) {
1707         forbid_setid("program input from stdin");
1708         rsfp = PerlIO_stdin();
1709     }
1710     else {
1711         rsfp = PerlIO_open(scriptname,"r");
1712 #if defined(HAS_FCNTL) && defined(F_SETFD)
1713         if (rsfp)
1714             fcntl(PerlIO_fileno(rsfp),F_SETFD,1);  /* ensure close-on-exec */
1715 #endif
1716     }
1717     if (e_tmpname) {
1718         e_fp = rsfp;
1719     }
1720     if (!rsfp) {
1721 #ifdef DOSUID
1722 #ifndef IAMSUID         /* in case script is not readable before setuid */
1723         if (euid && Stat(SvPVX(GvSV(curcop->cop_filegv)),&statbuf) >= 0 &&
1724           statbuf.st_mode & (S_ISUID|S_ISGID)) {
1725             (void)sprintf(buf, "%s/sperl%s", BIN, patchlevel);
1726             execv(buf, origargv);       /* try again */
1727             croak("Can't do setuid\n");
1728         }
1729 #endif
1730 #endif
1731         croak("Can't open perl script \"%s\": %s\n",
1732           SvPVX(GvSV(curcop->cop_filegv)), Strerror(errno));
1733     }
1734 }
1735
1736 static void
1737 validate_suid(validarg, scriptname)
1738 char *validarg;
1739 char *scriptname;
1740 {
1741     int which;
1742
1743     /* do we need to emulate setuid on scripts? */
1744
1745     /* This code is for those BSD systems that have setuid #! scripts disabled
1746      * in the kernel because of a security problem.  Merely defining DOSUID
1747      * in perl will not fix that problem, but if you have disabled setuid
1748      * scripts in the kernel, this will attempt to emulate setuid and setgid
1749      * on scripts that have those now-otherwise-useless bits set.  The setuid
1750      * root version must be called suidperl or sperlN.NNN.  If regular perl
1751      * discovers that it has opened a setuid script, it calls suidperl with
1752      * the same argv that it had.  If suidperl finds that the script it has
1753      * just opened is NOT setuid root, it sets the effective uid back to the
1754      * uid.  We don't just make perl setuid root because that loses the
1755      * effective uid we had before invoking perl, if it was different from the
1756      * uid.
1757      *
1758      * DOSUID must be defined in both perl and suidperl, and IAMSUID must
1759      * be defined in suidperl only.  suidperl must be setuid root.  The
1760      * Configure script will set this up for you if you want it.
1761      */
1762
1763 #ifdef DOSUID
1764     char *s, *s2;
1765
1766     if (Fstat(PerlIO_fileno(rsfp),&statbuf) < 0)        /* normal stat is insecure */
1767         croak("Can't stat script \"%s\"",origfilename);
1768     if (fdscript < 0 && statbuf.st_mode & (S_ISUID|S_ISGID)) {
1769         I32 len;
1770
1771 #ifdef IAMSUID
1772 #ifndef HAS_SETREUID
1773         /* On this access check to make sure the directories are readable,
1774          * there is actually a small window that the user could use to make
1775          * filename point to an accessible directory.  So there is a faint
1776          * chance that someone could execute a setuid script down in a
1777          * non-accessible directory.  I don't know what to do about that.
1778          * But I don't think it's too important.  The manual lies when
1779          * it says access() is useful in setuid programs.
1780          */
1781         if (access(SvPVX(GvSV(curcop->cop_filegv)),1))  /*double check*/
1782             croak("Permission denied");
1783 #else
1784         /* If we can swap euid and uid, then we can determine access rights
1785          * with a simple stat of the file, and then compare device and
1786          * inode to make sure we did stat() on the same file we opened.
1787          * Then we just have to make sure he or she can execute it.
1788          */
1789         {
1790             struct stat tmpstatbuf;
1791
1792             if (
1793 #ifdef HAS_SETREUID
1794                 setreuid(euid,uid) < 0
1795 #else
1796 # if HAS_SETRESUID
1797                 setresuid(euid,uid,(Uid_t)-1) < 0
1798 # endif
1799 #endif
1800                 || getuid() != euid || geteuid() != uid)
1801                 croak("Can't swap uid and euid");       /* really paranoid */
1802             if (Stat(SvPVX(GvSV(curcop->cop_filegv)),&tmpstatbuf) < 0)
1803                 croak("Permission denied");     /* testing full pathname here */
1804             if (tmpstatbuf.st_dev != statbuf.st_dev ||
1805                 tmpstatbuf.st_ino != statbuf.st_ino) {
1806                 (void)PerlIO_close(rsfp);
1807                 if (rsfp = my_popen("/bin/mail root","w")) {    /* heh, heh */
1808                     PerlIO_printf(rsfp,
1809 "User %ld tried to run dev %ld ino %ld in place of dev %ld ino %ld!\n\
1810 (Filename of set-id script was %s, uid %ld gid %ld.)\n\nSincerely,\nperl\n",
1811                         (long)uid,(long)tmpstatbuf.st_dev, (long)tmpstatbuf.st_ino,
1812                         (long)statbuf.st_dev, (long)statbuf.st_ino,
1813                         SvPVX(GvSV(curcop->cop_filegv)),
1814                         (long)statbuf.st_uid, (long)statbuf.st_gid);
1815                     (void)my_pclose(rsfp);
1816                 }
1817                 croak("Permission denied\n");
1818             }
1819             if (
1820 #ifdef HAS_SETREUID
1821               setreuid(uid,euid) < 0
1822 #else
1823 # if defined(HAS_SETRESUID)
1824               setresuid(uid,euid,(Uid_t)-1) < 0
1825 # endif
1826 #endif
1827               || getuid() != uid || geteuid() != euid)
1828                 croak("Can't reswap uid and euid");
1829             if (!cando(S_IXUSR,FALSE,&statbuf))         /* can real uid exec? */
1830                 croak("Permission denied\n");
1831         }
1832 #endif /* HAS_SETREUID */
1833 #endif /* IAMSUID */
1834
1835         if (!S_ISREG(statbuf.st_mode))
1836             croak("Permission denied");
1837         if (statbuf.st_mode & S_IWOTH)
1838             croak("Setuid/gid script is writable by world");
1839         doswitches = FALSE;             /* -s is insecure in suid */
1840         curcop->cop_line++;
1841         if (sv_gets(linestr, rsfp, 0) == Nullch ||
1842           strnNE(SvPV(linestr,na),"#!",2) )     /* required even on Sys V */
1843             croak("No #! line");
1844         s = SvPV(linestr,na)+2;
1845         if (*s == ' ') s++;
1846         while (!isSPACE(*s)) s++;
1847         for (s2 = s;  (s2 > SvPV(linestr,na)+2 &&
1848                        (isDIGIT(s2[-1]) || strchr("._-", s2[-1])));  s2--) ;
1849         if (strnNE(s2-4,"perl",4) && strnNE(s-9,"perl",4))  /* sanity check */
1850             croak("Not a perl script");
1851         while (*s == ' ' || *s == '\t') s++;
1852         /*
1853          * #! arg must be what we saw above.  They can invoke it by
1854          * mentioning suidperl explicitly, but they may not add any strange
1855          * arguments beyond what #! says if they do invoke suidperl that way.
1856          */
1857         len = strlen(validarg);
1858         if (strEQ(validarg," PHOOEY ") ||
1859             strnNE(s,validarg,len) || !isSPACE(s[len]))
1860             croak("Args must match #! line");
1861
1862 #ifndef IAMSUID
1863         if (euid != uid && (statbuf.st_mode & S_ISUID) &&
1864             euid == statbuf.st_uid)
1865             if (!do_undump)
1866                 croak("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
1867 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
1868 #endif /* IAMSUID */
1869
1870         if (euid) {     /* oops, we're not the setuid root perl */
1871             (void)PerlIO_close(rsfp);
1872 #ifndef IAMSUID
1873             (void)sprintf(buf, "%s/sperl%s", BIN, patchlevel);
1874             execv(buf, origargv);       /* try again */
1875 #endif
1876             croak("Can't do setuid\n");
1877         }
1878
1879         if (statbuf.st_mode & S_ISGID && statbuf.st_gid != egid) {
1880 #ifdef HAS_SETEGID
1881             (void)setegid(statbuf.st_gid);
1882 #else
1883 #ifdef HAS_SETREGID
1884            (void)setregid((Gid_t)-1,statbuf.st_gid);
1885 #else
1886 #ifdef HAS_SETRESGID
1887            (void)setresgid((Gid_t)-1,statbuf.st_gid,(Gid_t)-1);
1888 #else
1889             setgid(statbuf.st_gid);
1890 #endif
1891 #endif
1892 #endif
1893             if (getegid() != statbuf.st_gid)
1894                 croak("Can't do setegid!\n");
1895         }
1896         if (statbuf.st_mode & S_ISUID) {
1897             if (statbuf.st_uid != euid)
1898 #ifdef HAS_SETEUID
1899                 (void)seteuid(statbuf.st_uid);  /* all that for this */
1900 #else
1901 #ifdef HAS_SETREUID
1902                 (void)setreuid((Uid_t)-1,statbuf.st_uid);
1903 #else
1904 #ifdef HAS_SETRESUID
1905                 (void)setresuid((Uid_t)-1,statbuf.st_uid,(Uid_t)-1);
1906 #else
1907                 setuid(statbuf.st_uid);
1908 #endif
1909 #endif
1910 #endif
1911             if (geteuid() != statbuf.st_uid)
1912                 croak("Can't do seteuid!\n");
1913         }
1914         else if (uid) {                 /* oops, mustn't run as root */
1915 #ifdef HAS_SETEUID
1916           (void)seteuid((Uid_t)uid);
1917 #else
1918 #ifdef HAS_SETREUID
1919           (void)setreuid((Uid_t)-1,(Uid_t)uid);
1920 #else
1921 #ifdef HAS_SETRESUID
1922           (void)setresuid((Uid_t)-1,(Uid_t)uid,(Uid_t)-1);
1923 #else
1924           setuid((Uid_t)uid);
1925 #endif
1926 #endif
1927 #endif
1928             if (geteuid() != uid)
1929                 croak("Can't do seteuid!\n");
1930         }
1931         init_ids();
1932         if (!cando(S_IXUSR,TRUE,&statbuf))
1933             croak("Permission denied\n");       /* they can't do this */
1934     }
1935 #ifdef IAMSUID
1936     else if (preprocess)
1937         croak("-P not allowed for setuid/setgid script\n");
1938     else if (fdscript >= 0)
1939         croak("fd script not allowed in suidperl\n");
1940     else
1941         croak("Script is not setuid/setgid in suidperl\n");
1942
1943     /* We absolutely must clear out any saved ids here, so we */
1944     /* exec the real perl, substituting fd script for scriptname. */
1945     /* (We pass script name as "subdir" of fd, which perl will grok.) */
1946     PerlIO_rewind(rsfp);
1947     lseek(PerlIO_fileno(rsfp),(Off_t)0,0);  /* just in case rewind didn't */
1948     for (which = 1; origargv[which] && origargv[which] != scriptname; which++) ;
1949     if (!origargv[which])
1950         croak("Permission denied");
1951     (void)sprintf(buf, "/dev/fd/%d/%.127s", PerlIO_fileno(rsfp), origargv[which]);
1952     origargv[which] = buf;
1953
1954 #if defined(HAS_FCNTL) && defined(F_SETFD)
1955     fcntl(PerlIO_fileno(rsfp),F_SETFD,0);       /* ensure no close-on-exec */
1956 #endif
1957
1958     (void)sprintf(tokenbuf, "%s/perl%s", BIN, patchlevel);
1959     execv(tokenbuf, origargv);  /* try again */
1960     croak("Can't do setuid\n");
1961 #endif /* IAMSUID */
1962 #else /* !DOSUID */
1963     if (euid != uid || egid != gid) {   /* (suidperl doesn't exist, in fact) */
1964 #ifndef SETUID_SCRIPTS_ARE_SECURE_NOW
1965         Fstat(PerlIO_fileno(rsfp),&statbuf);    /* may be either wrapped or real suid */
1966         if ((euid != uid && euid == statbuf.st_uid && statbuf.st_mode & S_ISUID)
1967             ||
1968             (egid != gid && egid == statbuf.st_gid && statbuf.st_mode & S_ISGID)
1969            )
1970             if (!do_undump)
1971                 croak("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
1972 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
1973 #endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
1974         /* not set-id, must be wrapped */
1975     }
1976 #endif /* DOSUID */
1977 }
1978
1979 static void
1980 find_beginning()
1981 {
1982     register char *s, *s2;
1983
1984     /* skip forward in input to the real script? */
1985
1986     forbid_setid("-x");
1987     while (doextract) {
1988         if ((s = sv_gets(linestr, rsfp, 0)) == Nullch)
1989             croak("No Perl script found in input\n");
1990         if (*s == '#' && s[1] == '!' && (s = instr(s,"perl"))) {
1991             PerlIO_ungetc(rsfp, '\n');          /* to keep line count right */
1992             doextract = FALSE;
1993             while (*s && !(isSPACE (*s) || *s == '#')) s++;
1994             s2 = s;
1995             while (*s == ' ' || *s == '\t') s++;
1996             if (*s++ == '-') {
1997                 while (isDIGIT(s2[-1]) || strchr("-._", s2[-1])) s2--;
1998                 if (strnEQ(s2-4,"perl",4))
1999                     /*SUPPRESS 530*/
2000                     while (s = moreswitches(s)) ;
2001             }
2002             if (cddir && chdir(cddir) < 0)
2003                 croak("Can't chdir to %s",cddir);
2004         }
2005     }
2006 }
2007
2008 static void
2009 init_ids()
2010 {
2011     uid = (int)getuid();
2012     euid = (int)geteuid();
2013     gid = (int)getgid();
2014     egid = (int)getegid();
2015 #ifdef VMS
2016     uid |= gid << 16;
2017     euid |= egid << 16;
2018 #endif
2019     tainting |= (uid && (euid != uid || egid != gid));
2020 }
2021
2022 static void
2023 forbid_setid(s)
2024 char *s;
2025 {
2026     if (euid != uid)
2027         croak("No %s allowed while running setuid", s);
2028     if (egid != gid)
2029         croak("No %s allowed while running setgid", s);
2030 }
2031
2032 static void
2033 init_debugger()
2034 {
2035     curstash = debstash;
2036     dbargs = GvAV(gv_AVadd((gv_fetchpv("args", GV_ADDMULTI, SVt_PVAV))));
2037     AvREAL_off(dbargs);
2038     DBgv = gv_fetchpv("DB", GV_ADDMULTI, SVt_PVGV);
2039     DBline = gv_fetchpv("dbline", GV_ADDMULTI, SVt_PVAV);
2040     DBsub = gv_HVadd(gv_fetchpv("sub", GV_ADDMULTI, SVt_PVHV));
2041     DBsingle = GvSV((gv_fetchpv("single", GV_ADDMULTI, SVt_PV)));
2042     sv_setiv(DBsingle, 0);
2043     DBtrace = GvSV((gv_fetchpv("trace", GV_ADDMULTI, SVt_PV)));
2044     sv_setiv(DBtrace, 0);
2045     DBsignal = GvSV((gv_fetchpv("signal", GV_ADDMULTI, SVt_PV)));
2046     sv_setiv(DBsignal, 0);
2047     curstash = defstash;
2048 }
2049
2050 static void
2051 init_stacks()
2052 {
2053     curstack = newAV();
2054     mainstack = curstack;               /* remember in case we switch stacks */
2055     AvREAL_off(curstack);               /* not a real array */
2056     av_extend(curstack,127);
2057
2058     stack_base = AvARRAY(curstack);
2059     stack_sp = stack_base;
2060     stack_max = stack_base + 127;
2061
2062     cxstack_max = 8192 / sizeof(CONTEXT) - 2;   /* Use most of 8K. */
2063     New(50,cxstack,cxstack_max + 1,CONTEXT);
2064     cxstack_ix  = -1;
2065
2066     New(50,tmps_stack,128,SV*);
2067     tmps_ix = -1;
2068     tmps_max = 128;
2069
2070     DEBUG( {
2071         New(51,debname,128,char);
2072         New(52,debdelim,128,char);
2073     } )
2074
2075     /*
2076      * The following stacks almost certainly should be per-interpreter,
2077      * but for now they're not.  XXX
2078      */
2079
2080     if (markstack) {
2081         markstack_ptr = markstack;
2082     } else {
2083         New(54,markstack,64,I32);
2084         markstack_ptr = markstack;
2085         markstack_max = markstack + 64;
2086     }
2087
2088     if (scopestack) {
2089         scopestack_ix = 0;
2090     } else {
2091         New(54,scopestack,32,I32);
2092         scopestack_ix = 0;
2093         scopestack_max = 32;
2094     }
2095
2096     if (savestack) {
2097         savestack_ix = 0;
2098     } else {
2099         New(54,savestack,128,ANY);
2100         savestack_ix = 0;
2101         savestack_max = 128;
2102     }
2103
2104     if (retstack) {
2105         retstack_ix = 0;
2106     } else {
2107         New(54,retstack,16,OP*);
2108         retstack_ix = 0;
2109         retstack_max = 16;
2110     }
2111 }
2112
2113 static void
2114 nuke_stacks()
2115 {
2116     Safefree(cxstack);
2117     Safefree(tmps_stack);
2118     DEBUG( {
2119         Safefree(debname);
2120         Safefree(debdelim);
2121     } )
2122 }
2123
2124 static PerlIO *tmpfp;  /* moved outside init_lexer() because of UNICOS bug */
2125
2126 static void
2127 init_lexer()
2128 {
2129     tmpfp = rsfp;
2130     lex_start(linestr);
2131     rsfp = tmpfp;
2132     subname = newSVpv("main",4);
2133 }
2134
2135 static void
2136 init_predump_symbols()
2137 {
2138     GV *tmpgv;
2139     GV *othergv;
2140
2141     sv_setpvn(GvSV(gv_fetchpv("\"", TRUE, SVt_PV)), " ", 1);
2142
2143     stdingv = gv_fetchpv("STDIN",TRUE, SVt_PVIO);
2144     GvMULTI_on(stdingv);
2145     IoIFP(GvIOp(stdingv)) = PerlIO_stdin();
2146     tmpgv = gv_fetchpv("stdin",TRUE, SVt_PV);
2147     GvMULTI_on(tmpgv);
2148     GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(stdingv));
2149
2150     tmpgv = gv_fetchpv("STDOUT",TRUE, SVt_PVIO);
2151     GvMULTI_on(tmpgv);
2152     IoOFP(GvIOp(tmpgv)) = IoIFP(GvIOp(tmpgv)) = PerlIO_stdout();
2153     setdefout(tmpgv);
2154     tmpgv = gv_fetchpv("stdout",TRUE, SVt_PV);
2155     GvMULTI_on(tmpgv);
2156     GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(defoutgv));
2157
2158     othergv = gv_fetchpv("STDERR",TRUE, SVt_PVIO);
2159     GvMULTI_on(othergv);
2160     IoOFP(GvIOp(othergv)) = IoIFP(GvIOp(othergv)) = PerlIO_stderr();
2161     tmpgv = gv_fetchpv("stderr",TRUE, SVt_PV);
2162     GvMULTI_on(tmpgv);
2163     GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(othergv));
2164
2165     statname = NEWSV(66,0);             /* last filename we did stat on */
2166
2167     if (!osname)
2168         osname = savepv(OSNAME);
2169 }
2170
2171 static void
2172 init_postdump_symbols(argc,argv,env)
2173 register int argc;
2174 register char **argv;
2175 register char **env;
2176 {
2177     char *s;
2178     SV *sv;
2179     GV* tmpgv;
2180
2181     argc--,argv++;      /* skip name of script */
2182     if (doswitches) {
2183         for (; argc > 0 && **argv == '-'; argc--,argv++) {
2184             if (!argv[0][1])
2185                 break;
2186             if (argv[0][1] == '-') {
2187                 argc--,argv++;
2188                 break;
2189             }
2190             if (s = strchr(argv[0], '=')) {
2191                 *s++ = '\0';
2192                 sv_setpv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),s);
2193             }
2194             else
2195                 sv_setiv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),1);
2196         }
2197     }
2198     toptarget = NEWSV(0,0);
2199     sv_upgrade(toptarget, SVt_PVFM);
2200     sv_setpvn(toptarget, "", 0);
2201     bodytarget = NEWSV(0,0);
2202     sv_upgrade(bodytarget, SVt_PVFM);
2203     sv_setpvn(bodytarget, "", 0);
2204     formtarget = bodytarget;
2205
2206     TAINT;
2207     if (tmpgv = gv_fetchpv("0",TRUE, SVt_PV)) {
2208         sv_setpv(GvSV(tmpgv),origfilename);
2209         magicname("0", "0", 1);
2210     }
2211     if (tmpgv = gv_fetchpv("\030",TRUE, SVt_PV))
2212         sv_setpv(GvSV(tmpgv),origargv[0]);
2213     if (argvgv = gv_fetchpv("ARGV",TRUE, SVt_PVAV)) {
2214         GvMULTI_on(argvgv);
2215         (void)gv_AVadd(argvgv);
2216         av_clear(GvAVn(argvgv));
2217         for (; argc > 0; argc--,argv++) {
2218             av_push(GvAVn(argvgv),newSVpv(argv[0],0));
2219         }
2220     }
2221     if (envgv = gv_fetchpv("ENV",TRUE, SVt_PVHV)) {
2222         HV *hv;
2223         GvMULTI_on(envgv);
2224         hv = GvHVn(envgv);
2225         hv_clear(hv);
2226 #ifndef VMS  /* VMS doesn't have environ array */
2227         /* Note that if the supplied env parameter is actually a copy
2228            of the global environ then it may now point to free'd memory
2229            if the environment has been modified since. To avoid this
2230            problem we treat env==NULL as meaning 'use the default'
2231         */
2232         if (!env)
2233             env = environ;
2234         if (env != environ) {
2235             environ[0] = Nullch;
2236             hv_magic(hv, envgv, 'E');
2237         }
2238         for (; *env; env++) {
2239             if (!(s = strchr(*env,'=')))
2240                 continue;
2241             *s++ = '\0';
2242             sv = newSVpv(s--,0);
2243             sv_magic(sv, sv, 'e', *env, s - *env);
2244             (void)hv_store(hv, *env, s - *env, sv, 0);
2245             *s = '=';
2246         }
2247 #endif
2248 #ifdef DYNAMIC_ENV_FETCH
2249         HvNAME(hv) = savepv(ENV_HV_NAME);
2250 #endif
2251         hv_magic(hv, envgv, 'E');
2252     }
2253     TAINT_NOT;
2254     if (tmpgv = gv_fetchpv("$",TRUE, SVt_PV))
2255         sv_setiv(GvSV(tmpgv),(I32)getpid());
2256 }
2257
2258 static void
2259 init_perllib()
2260 {
2261     char *s;
2262     if (!tainting) {
2263 #ifndef VMS
2264         s = getenv("PERL5LIB");
2265         if (s)
2266             incpush(s, TRUE);
2267         else
2268             incpush(getenv("PERLLIB"), FALSE);
2269 #else /* VMS */
2270         /* Treat PERL5?LIB as a possible search list logical name -- the
2271          * "natural" VMS idiom for a Unix path string.  We allow each
2272          * element to be a set of |-separated directories for compatibility.
2273          */
2274         char buf[256];
2275         int idx = 0;
2276         if (my_trnlnm("PERL5LIB",buf,0))
2277             do { incpush(buf,TRUE); } while (my_trnlnm("PERL5LIB",buf,++idx));
2278         else
2279             while (my_trnlnm("PERLLIB",buf,idx++)) incpush(buf,FALSE);
2280 #endif /* VMS */
2281     }
2282
2283 /* Use the ~-expanded versions of APPLIB (undocumented),
2284     ARCHLIB PRIVLIB SITEARCH SITELIB and OLDARCHLIB
2285 */
2286 #ifdef APPLLIB_EXP
2287     incpush(APPLLIB_EXP, FALSE);
2288 #endif
2289
2290 #ifdef ARCHLIB_EXP
2291     incpush(ARCHLIB_EXP, FALSE);
2292 #endif
2293 #ifndef PRIVLIB_EXP
2294 #define PRIVLIB_EXP "/usr/local/lib/perl5:/usr/local/lib/perl"
2295 #endif
2296     incpush(PRIVLIB_EXP, FALSE);
2297
2298 #ifdef SITEARCH_EXP
2299     incpush(SITEARCH_EXP, FALSE);
2300 #endif
2301 #ifdef SITELIB_EXP
2302     incpush(SITELIB_EXP, FALSE);
2303 #endif
2304 #ifdef OLDARCHLIB_EXP  /* 5.00[01] compatibility */
2305     incpush(OLDARCHLIB_EXP, FALSE);
2306 #endif
2307
2308     if (!tainting)
2309         incpush(".", FALSE);
2310 }
2311
2312 #if defined(DOSISH)
2313 #    define PERLLIB_SEP ';'
2314 #else
2315 #  if defined(VMS)
2316 #    define PERLLIB_SEP '|'
2317 #  else
2318 #    define PERLLIB_SEP ':'
2319 #  endif
2320 #endif
2321 #ifndef PERLLIB_MANGLE
2322 #  define PERLLIB_MANGLE(s,n) (s)
2323 #endif
2324
2325 static void
2326 incpush(p, addsubdirs)
2327 char *p;
2328 int addsubdirs;
2329 {
2330     SV *subdir = Nullsv;
2331     static char *archpat_auto;
2332
2333     if (!p)
2334         return;
2335
2336     if (addsubdirs) {
2337         subdir = newSV(0);
2338         if (!archpat_auto) {
2339             STRLEN len = (sizeof(ARCHNAME) + strlen(patchlevel)
2340                           + sizeof("//auto"));
2341             New(55, archpat_auto, len, char);
2342             sprintf(archpat_auto, "/%s/%s/auto", ARCHNAME, patchlevel);
2343 #ifdef VMS
2344         for (len = sizeof(ARCHNAME) + 2;
2345              archpat_auto[len] != '\0' && archpat_auto[len] != '/'; len++)
2346                 if (archpat_auto[len] == '.') archpat_auto[len] = '_';
2347 #endif
2348         }
2349     }
2350
2351     /* Break at all separators */
2352     while (p && *p) {
2353         SV *libdir = newSV(0);
2354         char *s;
2355
2356         /* skip any consecutive separators */
2357         while ( *p == PERLLIB_SEP ) {
2358             /* Uncomment the next line for PATH semantics */
2359             /* av_push(GvAVn(incgv), newSVpv(".", 1)); */
2360             p++;
2361         }
2362
2363         if ( (s = strchr(p, PERLLIB_SEP)) != Nullch ) {
2364             sv_setpvn(libdir, PERLLIB_MANGLE(p, (STRLEN)(s - p)),
2365                       (STRLEN)(s - p));
2366             p = s + 1;
2367         }
2368         else {
2369             sv_setpv(libdir, PERLLIB_MANGLE(p, 0));
2370             p = Nullch; /* break out */
2371         }
2372
2373         /*
2374          * BEFORE pushing libdir onto @INC we may first push version- and
2375          * archname-specific sub-directories.
2376          */
2377         if (addsubdirs) {
2378             struct stat tmpstatbuf;
2379 #ifdef VMS
2380             char *unix;
2381             STRLEN len;
2382
2383             if ((unix = tounixspec_ts(SvPV(libdir,na),Nullch)) != Nullch) {
2384                 len = strlen(unix);
2385                 while (unix[len-1] == '/') len--;  /* Cosmetic */
2386                 sv_usepvn(libdir,unix,len);
2387             }
2388             else
2389                 PerlIO_printf(PerlIO_stderr(),
2390                               "Failed to unixify @INC element \"%s\"\n",
2391                               SvPV(libdir,na));
2392 #endif
2393             /* .../archname/version if -d .../archname/version/auto */
2394             sv_setsv(subdir, libdir);
2395             sv_catpv(subdir, archpat_auto);
2396             if (Stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
2397                   S_ISDIR(tmpstatbuf.st_mode))
2398                 av_push(GvAVn(incgv),
2399                         newSVpv(SvPVX(subdir), SvCUR(subdir) - sizeof "auto"));
2400
2401             /* .../archname if -d .../archname/auto */
2402             sv_insert(subdir, SvCUR(libdir) + sizeof(ARCHNAME),
2403                       strlen(patchlevel) + 1, "", 0);
2404             if (Stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
2405                   S_ISDIR(tmpstatbuf.st_mode))
2406                 av_push(GvAVn(incgv),
2407                         newSVpv(SvPVX(subdir), SvCUR(subdir) - sizeof "auto"));
2408         }
2409
2410         /* finally push this lib directory on the end of @INC */
2411         av_push(GvAVn(incgv), libdir);
2412     }
2413
2414     SvREFCNT_dec(subdir);
2415 }
2416
2417 void
2418 calllist(list)
2419 AV* list;
2420 {
2421     Sigjmp_buf oldtop;
2422     STRLEN len;
2423     line_t oldline = curcop->cop_line;
2424
2425     Copy(top_env, oldtop, 1, Sigjmp_buf);
2426
2427     while (AvFILL(list) >= 0) {
2428         CV *cv = (CV*)av_shift(list);
2429
2430         SAVEFREESV(cv);
2431
2432         switch (Sigsetjmp(top_env,1)) {
2433         case 0: {
2434                 SV* atsv = GvSV(errgv);
2435                 PUSHMARK(stack_sp);
2436                 perl_call_sv((SV*)cv, G_EVAL|G_DISCARD);
2437                 (void)SvPV(atsv, len);
2438                 if (len) {
2439                     Copy(oldtop, top_env, 1, Sigjmp_buf);
2440                     curcop = &compiling;
2441                     curcop->cop_line = oldline;
2442                     if (list == beginav)
2443                         sv_catpv(atsv, "BEGIN failed--compilation aborted");
2444                     else
2445                         sv_catpv(atsv, "END failed--cleanup aborted");
2446                     croak("%s", SvPVX(atsv));
2447                 }
2448             }
2449             break;
2450         case 1:
2451             STATUS_ALL_FAILURE;
2452             /* FALL THROUGH */
2453         case 2:
2454             /* my_exit() was called */
2455             curstash = defstash;
2456             if (endav)
2457                 calllist(endav);
2458             FREETMPS;
2459             Copy(oldtop, top_env, 1, Sigjmp_buf);
2460             curcop = &compiling;
2461             curcop->cop_line = oldline;
2462             if (statusvalue) {
2463                 if (list == beginav)
2464                     croak("BEGIN failed--compilation aborted");
2465                 else
2466                     croak("END failed--cleanup aborted");
2467             }
2468             my_exit_jump();
2469             /* NOTREACHED */
2470         case 3:
2471             if (!restartop) {
2472                 PerlIO_printf(PerlIO_stderr(), "panic: restartop\n");
2473                 FREETMPS;
2474                 break;
2475             }
2476             Copy(oldtop, top_env, 1, Sigjmp_buf);
2477             curcop = &compiling;
2478             curcop->cop_line = oldline;
2479             Siglongjmp(top_env, 3);
2480         }
2481     }
2482
2483     Copy(oldtop, top_env, 1, Sigjmp_buf);
2484 }
2485
2486 void
2487 my_exit(status)
2488 U32 status;
2489 {
2490     switch (status) {
2491     case 0:
2492         STATUS_ALL_SUCCESS;
2493         break;
2494     case 1:
2495         STATUS_ALL_FAILURE;
2496         break;
2497     default:
2498         STATUS_NATIVE_SET(status);
2499         break;
2500     }
2501     my_exit_jump();
2502 }
2503
2504 void
2505 my_failure_exit()
2506 {
2507 #ifdef VMS
2508     if (vaxc$errno & 1) {
2509         if (STATUS_NATIVE & 1)          /* fortuitiously includes "-1" */
2510             STATUS_NATIVE_SET(44);
2511     }
2512     else {
2513         if (!vaxc$errno && errno)       /* unlikely */
2514             STATUS_NATIVE_SET(44);
2515         else
2516             STATUS_NATIVE_SET(vaxc$errno);
2517     }
2518 #else
2519     if (errno & 255)
2520         STATUS_POSIX_SET(errno);
2521     else if (STATUS_POSIX == 0)
2522         STATUS_POSIX_SET(255);
2523 #endif
2524     my_exit_jump();
2525 }
2526
2527 static void
2528 my_exit_jump()
2529 {
2530     register CONTEXT *cx;
2531     I32 gimme;
2532     SV **newsp;
2533
2534     if (e_tmpname) {
2535         if (e_fp) {
2536             PerlIO_close(e_fp);
2537             e_fp = Nullfp;
2538         }
2539         (void)UNLINK(e_tmpname);
2540         Safefree(e_tmpname);
2541         e_tmpname = Nullch;
2542     }
2543
2544     if (cxstack_ix >= 0) {
2545         if (cxstack_ix > 0)
2546             dounwind(0);
2547         POPBLOCK(cx,curpm);
2548         LEAVE;
2549     }
2550
2551     Siglongjmp(top_env, 2);
2552 }