perl.c

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