perl.c

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