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