perl.c

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