perl.c

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