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