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