perl.c

   1 /*    perl.c
   2  *
   3  *    Copyright (c) 1987-1998 Larry Wall
   4  *
   5  *    You may distribute under the terms of either the GNU General Public
   6  *    License or the Artistic License, as specified in the README file.
   7  *
   8  */
   9
  10 /*
  11  * "A ship then new they built for him/of mithril and of elven glass" --Bilbo
  12  */
  13
  14 #include "EXTERN.h"
  15 #include "perl.h"
  16 #include "patchlevel.h"
  17
  18 /* XXX If this causes problems, set i_unistd=undef in the hint file.  */
  19 #ifdef I_UNISTD
  20 #include <unistd.h>
  21 #endif
  22
  23 #if !defined(STANDARD_C) && !defined(HAS_GETENV_PROTOTYPE)
  24 char *getenv _((char *)); /* Usually in <stdlib.h> */
  25 #endif
  26
  27 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
 944     if (xsinit)
 945         (*xsinit)(THIS);        /* in case linked C routines want magical variables */
 946 #if defined(VMS) || defined(WIN32) || defined(DJGPP)
 947     init_os_extras();
 948 #endif
 949
 950 #if defined(DEBUGGING) && defined(USE_THREADS) && defined(__linux__)
 951     DEBUG_L(PerlProc_signal(SIGSEGV, (void(*)(int))catch_sigsegv););
 952 #endif
 953
 954     init_predump_symbols();
 955     if (!do_undump)
 956         init_postdump_symbols(argc,argv,env);
 957
 958     init_lexer();
 959
 960     /* now parse the script */
 961
 962     SETERRNO(0,SS$_NORMAL);
 963     error_count = 0;
 964     if (yyparse() || error_count) {
 965         if (minus_c)
 966             croak("%s had compilation errors.\n", origfilename);
 967         else {
 968             croak("Execution of %s aborted due to compilation errors.\n",
 969                 origfilename);
 970         }
 971     }
 972     curcop->cop_line = 0;
 973     curstash = defstash;
 974     preprocess = FALSE;
 975     if (e_tmpname) {
 976         (void)UNLINK(e_tmpname);
 977         Safefree(e_tmpname);
 978         e_tmpname = Nullch;
 979     }
 980
 981     /* now that script is parsed, we can modify record separator */
 982     SvREFCNT_dec(rs);
 983     rs = SvREFCNT_inc(nrs);
 984     sv_setsv(perl_get_sv("/", TRUE), rs);
 985     if (do_undump)
 986         my_unexec();
 987
 988     if (dowarn)
 989         gv_check(defstash);
 990
 991     LEAVE;
 992     FREETMPS;
 993
 994 #ifdef MYMALLOC
 995     if ((s=PerlEnv_getenv("PERL_DEBUG_MSTATS")) && atoi(s) >= 2)
 996         dump_mstats("after compilation:");
 997 #endif
 998
 999     ENTER;
1000     restartop = 0;
1001     JMPENV_POP;
1002     return 0;
1003 }
1004
1005 int
1006 #ifdef PERL_OBJECT
1007 CPerlObj::perl_run(void)
1008 #else
1009 perl_run(PerlInterpreter *sv_interp)
1010 #endif
1011 {
1012     dTHR;
1013     I32 oldscope;
1014     dJMPENV;
1015     int ret;
1016
1017 #ifndef PERL_OBJECT
1018     if (!(curinterp = sv_interp))
1019         return 255;
1020 #endif
1021
1022     oldscope = scopestack_ix;
1023
1024     JMPENV_PUSH(ret);
1025     switch (ret) {
1026     case 1:
1027         cxstack_ix = -1;                /* start context stack again */
1028         break;
1029     case 2:
1030         /* my_exit() was called */
1031         while (scopestack_ix > oldscope)
1032             LEAVE;
1033         FREETMPS;
1034         curstash = defstash;
1035         if (endav)
1036             call_list(oldscope, endav);
1037 #ifdef MYMALLOC
1038         if (PerlEnv_getenv("PERL_DEBUG_MSTATS"))
1039             dump_mstats("after execution:  ");
1040 #endif
1041         JMPENV_POP;
1042         return STATUS_NATIVE_EXPORT;
1043     case 3:
1044         if (!restartop) {
1045             PerlIO_printf(PerlIO_stderr(), "panic: restartop\n");
1046             FREETMPS;
1047             JMPENV_POP;
1048             return 1;
1049         }
1050         if (curstack != mainstack) {
1051             dSP;
1052             SWITCHSTACK(curstack, mainstack);
1053         }
1054         break;
1055     }
1056
1057     DEBUG_r(PerlIO_printf(Perl_debug_log, "%s $` $& $' support.\n",
1058                     sawampersand ? "Enabling" : "Omitting"));
1059
1060     if (!restartop) {
1061         DEBUG_x(dump_all());
1062         DEBUG(PerlIO_printf(Perl_debug_log, "\nEXECUTING...\n\n"));
1063 #ifdef USE_THREADS
1064         DEBUG_L(PerlIO_printf(Perl_debug_log, "main thread is 0x%lx\n",
1065                               (unsigned long) thr));
1066 #endif /* USE_THREADS */
1067
1068         if (minus_c) {
1069             PerlIO_printf(PerlIO_stderr(), "%s syntax OK\n", origfilename);
1070             my_exit(0);
1071         }
1072         if (PERLDB_SINGLE && DBsingle)
1073            sv_setiv(DBsingle, 1);
1074         if (initav)
1075             call_list(oldscope, initav);
1076     }
1077
1078     /* do it */
1079
1080     if (restartop) {
1081         op = restartop;
1082         restartop = 0;
1083         CALLRUNOPS();
1084     }
1085     else if (main_start) {
1086         CvDEPTH(main_cv) = 1;
1087         op = main_start;
1088         CALLRUNOPS();
1089     }
1090
1091     my_exit(0);
1092     /* NOTREACHED */
1093     return 0;
1094 }
1095
1096 SV*
1097 perl_get_sv(char *name, I32 create)
1098 {
1099     GV *gv;
1100 #ifdef USE_THREADS
1101     if (name[1] == '\0' && !isALPHA(name[0])) {
1102         PADOFFSET tmp = find_threadsv(name);
1103         if (tmp != NOT_IN_PAD) {
1104             dTHR;
1105             return THREADSV(tmp);
1106         }
1107     }
1108 #endif /* USE_THREADS */
1109     gv = gv_fetchpv(name, create, SVt_PV);
1110     if (gv)
1111         return GvSV(gv);
1112     return Nullsv;
1113 }
1114
1115 AV*
1116 perl_get_av(char *name, I32 create)
1117 {
1118     GV* gv = gv_fetchpv(name, create, SVt_PVAV);
1119     if (create)
1120         return GvAVn(gv);
1121     if (gv)
1122         return GvAV(gv);
1123     return Nullav;
1124 }
1125
1126 HV*
1127 perl_get_hv(char *name, I32 create)
1128 {
1129     GV* gv = gv_fetchpv(name, create, SVt_PVHV);
1130     if (create)
1131         return GvHVn(gv);
1132     if (gv)
1133         return GvHV(gv);
1134     return Nullhv;
1135 }
1136
1137 CV*
1138 perl_get_cv(char *name, I32 create)
1139 {
1140     GV* gv = gv_fetchpv(name, create, SVt_PVCV);
1141     if (create && !GvCVu(gv))
1142         return newSUB(start_subparse(FALSE, 0),
1143                       newSVOP(OP_CONST, 0, newSVpv(name,0)),
1144                       Nullop,
1145                       Nullop);
1146     if (gv)
1147         return GvCVu(gv);
1148     return Nullcv;
1149 }
1150
1151 /* Be sure to refetch the stack pointer after calling these routines. */
1152
1153 I32
1154 perl_call_argv(char *sub_name, I32 flags, register char **argv)
1155
1156                         /* See G_* flags in cop.h */
1157                         /* null terminated arg list */
1158 {
1159     dSP;
1160
1161     PUSHMARK(sp);
1162     if (argv) {
1163         while (*argv) {
1164             XPUSHs(sv_2mortal(newSVpv(*argv,0)));
1165             argv++;
1166         }
1167         PUTBACK;
1168     }
1169     return perl_call_pv(sub_name, flags);
1170 }
1171
1172 I32
1173 perl_call_pv(char *sub_name, I32 flags)
1174                         /* name of the subroutine */
1175                         /* See G_* flags in cop.h */
1176 {
1177     return perl_call_sv((SV*)perl_get_cv(sub_name, TRUE), flags);
1178 }
1179
1180 I32
1181 perl_call_method(char *methname, I32 flags)
1182                         /* name of the subroutine */
1183                         /* See G_* flags in cop.h */
1184 {
1185     dSP;
1186     OP myop;
1187     if (!op)
1188         op = &myop;
1189     XPUSHs(sv_2mortal(newSVpv(methname,0)));
1190     PUTBACK;
1191     pp_method(ARGS);
1192     return perl_call_sv(*stack_sp--, flags);
1193 }
1194
1195 /* May be called with any of a CV, a GV, or an SV containing the name. */
1196 I32
1197 perl_call_sv(SV *sv, I32 flags)
1198
1199                         /* See G_* flags in cop.h */
1200 {
1201     dTHR;
1202     LOGOP myop;         /* fake syntax tree node */
1203     SV** sp = stack_sp;
1204     I32 oldmark;
1205     I32 retval;
1206     I32 oldscope;
1207     bool oldcatch = CATCH_GET;
1208     dJMPENV;
1209     int ret;
1210     OP* oldop = op;
1211
1212     if (flags & G_DISCARD) {
1213         ENTER;
1214         SAVETMPS;
1215     }
1216
1217     Zero(&myop, 1, LOGOP);
1218     myop.op_next = Nullop;
1219     if (!(flags & G_NOARGS))
1220         myop.op_flags |= OPf_STACKED;
1221     myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
1222                       (flags & G_ARRAY) ? OPf_WANT_LIST :
1223                       OPf_WANT_SCALAR);
1224     SAVEOP();
1225     op = (OP*)&myop;
1226
1227     EXTEND(stack_sp, 1);
1228     *++stack_sp = sv;
1229     oldmark = TOPMARK;
1230     oldscope = scopestack_ix;
1231
1232     if (PERLDB_SUB && curstash != debstash
1233            /* Handle first BEGIN of -d. */
1234           && (DBcv || (DBcv = GvCV(DBsub)))
1235            /* Try harder, since this may have been a sighandler, thus
1236             * curstash may be meaningless. */
1237           && (SvTYPE(sv) != SVt_PVCV || CvSTASH((CV*)sv) != debstash))
1238         op->op_private |= OPpENTERSUB_DB;
1239
1240     if (flags & G_EVAL) {
1241         cLOGOP->op_other = op;
1242         markstack_ptr--;
1243         /* we're trying to emulate pp_entertry() here */
1244         {
1245             register PERL_CONTEXT *cx;
1246             I32 gimme = GIMME_V;
1247
1248             ENTER;
1249             SAVETMPS;
1250
1251             push_return(op->op_next);
1252             PUSHBLOCK(cx, CXt_EVAL, stack_sp);
1253             PUSHEVAL(cx, 0, 0);
1254             eval_root = op;             /* Only needed so that goto works right. */
1255
1256             in_eval = 1;
1257             if (flags & G_KEEPERR)
1258                 in_eval |= 4;
1259             else
1260                 sv_setpv(ERRSV,"");
1261         }
1262         markstack_ptr++;
1263
1264         JMPENV_PUSH(ret);
1265         switch (ret) {
1266         case 0:
1267             break;
1268         case 1:
1269             STATUS_ALL_FAILURE;
1270             /* FALL THROUGH */
1271         case 2:
1272             /* my_exit() was called */
1273             curstash = defstash;
1274             FREETMPS;
1275             JMPENV_POP;
1276             if (statusvalue)
1277                 croak("Callback called exit");
1278             my_exit_jump();
1279             /* NOTREACHED */
1280         case 3:
1281             if (restartop) {
1282                 op = restartop;
1283                 restartop = 0;
1284                 break;
1285             }
1286             stack_sp = stack_base + oldmark;
1287             if (flags & G_ARRAY)
1288                 retval = 0;
1289             else {
1290                 retval = 1;
1291                 *++stack_sp = &sv_undef;
1292             }
1293             goto cleanup;
1294         }
1295     }
1296     else
1297         CATCH_SET(TRUE);
1298
1299     if (op == (OP*)&myop)
1300         op = pp_entersub(ARGS);
1301     if (op)
1302         CALLRUNOPS();
1303     retval = stack_sp - (stack_base + oldmark);
1304     if ((flags & G_EVAL) && !(flags & G_KEEPERR))
1305         sv_setpv(ERRSV,"");
1306
1307   cleanup:
1308     if (flags & G_EVAL) {
1309         if (scopestack_ix > oldscope) {
1310             SV **newsp;
1311             PMOP *newpm;
1312             I32 gimme;
1313             register PERL_CONTEXT *cx;
1314             I32 optype;
1315
1316             POPBLOCK(cx,newpm);
1317             POPEVAL(cx);
1318             pop_return();
1319             curpm = newpm;
1320             LEAVE;
1321         }
1322         JMPENV_POP;
1323     }
1324     else
1325         CATCH_SET(oldcatch);
1326
1327     if (flags & G_DISCARD) {
1328         stack_sp = stack_base + oldmark;
1329         retval = 0;
1330         FREETMPS;
1331         LEAVE;
1332     }
1333     op = oldop;
1334     return retval;
1335 }
1336
1337 /* Eval a string. The G_EVAL flag is always assumed. */
1338
1339 I32
1340 perl_eval_sv(SV *sv, I32 flags)
1341
1342                         /* See G_* flags in cop.h */
1343 {
1344     dTHR;
1345     UNOP myop;          /* fake syntax tree node */
1346     SV** sp = stack_sp;
1347     I32 oldmark = sp - stack_base;
1348     I32 retval;
1349     I32 oldscope;
1350     dJMPENV;
1351     int ret;
1352     OP* oldop = op;
1353
1354     if (flags & G_DISCARD) {
1355         ENTER;
1356         SAVETMPS;
1357     }
1358
1359     SAVEOP();
1360     op = (OP*)&myop;
1361     Zero(op, 1, UNOP);
1362     EXTEND(stack_sp, 1);
1363     *++stack_sp = sv;
1364     oldscope = scopestack_ix;
1365
1366     if (!(flags & G_NOARGS))
1367         myop.op_flags = OPf_STACKED;
1368     myop.op_next = Nullop;
1369     myop.op_type = OP_ENTEREVAL;
1370     myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
1371                       (flags & G_ARRAY) ? OPf_WANT_LIST :
1372                       OPf_WANT_SCALAR);
1373     if (flags & G_KEEPERR)
1374         myop.op_flags |= OPf_SPECIAL;
1375
1376     JMPENV_PUSH(ret);
1377     switch (ret) {
1378     case 0:
1379         break;
1380     case 1:
1381         STATUS_ALL_FAILURE;
1382         /* FALL THROUGH */
1383     case 2:
1384         /* my_exit() was called */
1385         curstash = defstash;
1386         FREETMPS;
1387         JMPENV_POP;
1388         if (statusvalue)
1389             croak("Callback called exit");
1390         my_exit_jump();
1391         /* NOTREACHED */
1392     case 3:
1393         if (restartop) {
1394             op = restartop;
1395             restartop = 0;
1396             break;
1397         }
1398         stack_sp = stack_base + oldmark;
1399         if (flags & G_ARRAY)
1400             retval = 0;
1401         else {
1402             retval = 1;
1403             *++stack_sp = &sv_undef;
1404         }
1405         goto cleanup;
1406     }
1407
1408     if (op == (OP*)&myop)
1409         op = pp_entereval(ARGS);
1410     if (op)
1411         CALLRUNOPS();
1412     retval = stack_sp - (stack_base + oldmark);
1413     if (!(flags & G_KEEPERR))
1414         sv_setpv(ERRSV,"");
1415
1416   cleanup:
1417     JMPENV_POP;
1418     if (flags & G_DISCARD) {
1419         stack_sp = stack_base + oldmark;
1420         retval = 0;
1421         FREETMPS;
1422         LEAVE;
1423     }
1424     op = oldop;
1425     return retval;
1426 }
1427
1428 SV*
1429 perl_eval_pv(char *p, I32 croak_on_error)
1430 {
1431     dSP;
1432     SV* sv = newSVpv(p, 0);
1433
1434     PUSHMARK(sp);
1435     perl_eval_sv(sv, G_SCALAR);
1436     SvREFCNT_dec(sv);
1437
1438     SPAGAIN;
1439     sv = POPs;
1440     PUTBACK;
1441
1442     if (croak_on_error && SvTRUE(ERRSV))
1443         croak(SvPVx(ERRSV, na));
1444
1445     return sv;
1446 }
1447
1448 /* Require a module. */
1449
1450 void
1451 perl_require_pv(char *pv)
1452 {
1453     SV* sv = sv_newmortal();
1454     sv_setpv(sv, "require '");
1455     sv_catpv(sv, pv);
1456     sv_catpv(sv, "'");
1457     perl_eval_sv(sv, G_DISCARD);
1458 }
1459
1460 void
1461 magicname(char *sym, char *name, I32 namlen)
1462 {
1463     register GV *gv;
1464
1465     if (gv = gv_fetchpv(sym,TRUE, SVt_PV))
1466         sv_magic(GvSV(gv), (SV*)gv, 0, name, namlen);
1467 }
1468
1469 STATIC void
1470 usage(char *name)               /* XXX move this out into a module ? */
1471
1472 {
1473     /* This message really ought to be max 23 lines.
1474      * Removed -h because the user already knows that opton. Others? */
1475
1476     static char *usage_msg[] = {
1477 "-0[octal]       specify record separator (\\0, if no argument)",
1478 "-a              autosplit mode with -n or -p (splits $_ into @F)",
1479 "-c              check syntax only (runs BEGIN and END blocks)",
1480 "-d[:debugger]   run scripts under debugger",
1481 "-D[number/list] set debugging flags (argument is a bit mask or flags)",
1482 "-e 'command'    one line of script. Several -e's allowed. Omit [programfile].",
1483 "-F/pattern/     split() pattern for autosplit (-a). The //'s are optional.",
1484 "-i[extension]   edit <> files in place (make backup if extension supplied)",
1485 "-Idirectory     specify @INC/#include directory (may be used more than once)",
1486 "-l[octal]       enable line ending processing, specifies line terminator",
1487 "-[mM][-]module.. executes `use/no module...' before executing your script.",
1488 "-n              assume 'while (<>) { ... }' loop around your script",
1489 "-p              assume loop like -n but print line also like sed",
1490 "-P              run script through C preprocessor before compilation",
1491 "-s              enable some switch parsing for switches after script name",
1492 "-S              look for the script using PATH environment variable",
1493 "-T              turn on tainting checks",
1494 "-u              dump core after parsing script",
1495 "-U              allow unsafe operations",
1496 "-v              print version number and patchlevel of perl",
1497 "-V[:variable]   print perl configuration information",
1498 "-w              TURN WARNINGS ON FOR COMPILATION OF YOUR SCRIPT. Recommended.",
1499 "-x[directory]   strip off text before #!perl line and perhaps cd to directory",
1500 "\n",
1501 NULL
1502 };
1503     char **p = usage_msg;
1504
1505     printf("\nUsage: %s [switches] [--] [programfile] [arguments]", name);
1506     while (*p)
1507         printf("\n  %s", *p++);
1508 }
1509
1510 /* This routine handles any switches that can be given during run */
1511
1512 char *
1513 moreswitches(char *s)
1514 {
1515     I32 numlen;
1516     U32 rschar;
1517
1518     switch (*s) {
1519     case '0':
1520     {
1521         dTHR;
1522         rschar = scan_oct(s, 4, &numlen);
1523         SvREFCNT_dec(nrs);
1524         if (rschar & ~((U8)~0))
1525             nrs = &sv_undef;
1526         else if (!rschar && numlen >= 2)
1527             nrs = newSVpv("", 0);
1528         else {
1529             char ch = rschar;
1530             nrs = newSVpv(&ch, 1);
1531         }
1532         return s + numlen;
1533     }
1534     case 'F':
1535         minus_F = TRUE;
1536         splitstr = savepv(s + 1);
1537         s += strlen(s);
1538         return s;
1539     case 'a':
1540         minus_a = TRUE;
1541         s++;
1542         return s;
1543     case 'c':
1544         minus_c = TRUE;
1545         s++;
1546         return s;
1547     case 'd':
1548         forbid_setid("-d");
1549         s++;
1550         if (*s == ':' || *s == '=')  {
1551             my_setenv("PERL5DB", form("use Devel::%s;", ++s));
1552             s += strlen(s);
1553         }
1554         if (!perldb) {
1555             perldb = PERLDB_ALL;
1556             init_debugger();
1557         }
1558         return s;
1559     case 'D':
1560 #ifdef DEBUGGING
1561         forbid_setid("-D");
1562         if (isALPHA(s[1])) {
1563             static char debopts[] = "psltocPmfrxuLHXD";
1564             char *d;
1565
1566             for (s++; *s && (d = strchr(debopts,*s)); s++)
1567                 debug |= 1 << (d - debopts);
1568         }
1569         else {
1570             debug = atoi(s+1);
1571             for (s++; isDIGIT(*s); s++) ;
1572         }
1573         debug |= 0x80000000;
1574 #else
1575         warn("Recompile perl with -DDEBUGGING to use -D switch\n");
1576         for (s++; isALNUM(*s); s++) ;
1577 #endif
1578         /*SUPPRESS 530*/
1579         return s;
1580     case 'h':
1581         usage(origargv[0]);
1582         PerlProc_exit(0);
1583     case 'i':
1584         if (inplace)
1585             Safefree(inplace);
1586         inplace = savepv(s+1);
1587         /*SUPPRESS 530*/
1588         for (s = inplace; *s && !isSPACE(*s); s++) ;
1589         if (*s)
1590             *s++ = '\0';
1591         return s;
1592     case 'I':   /* -I handled both here and in parse_perl() */
1593         forbid_setid("-I");
1594         ++s;
1595         while (*s && isSPACE(*s))
1596             ++s;
1597         if (*s) {
1598             char *e, *p;
1599             for (e = s; *e && !isSPACE(*e); e++) ;
1600             p = savepvn(s, e-s);
1601             incpush(p, TRUE);
1602             Safefree(p);
1603             s = e;
1604         }
1605         else
1606             croak("No space allowed after -I");
1607         return s;
1608     case 'l':
1609         minus_l = TRUE;
1610         s++;
1611         if (ors)
1612             Safefree(ors);
1613         if (isDIGIT(*s)) {
1614             ors = savepv("\n");
1615             orslen = 1;
1616             *ors = scan_oct(s, 3 + (*s == '0'), &numlen);
1617             s += numlen;
1618         }
1619         else {
1620             dTHR;
1621             if (RsPARA(nrs)) {
1622                 ors = "\n\n";
1623                 orslen = 2;
1624             }
1625             else
1626                 ors = SvPV(nrs, orslen);
1627             ors = savepvn(ors, orslen);
1628         }
1629         return s;
1630     case 'M':
1631         forbid_setid("-M");     /* XXX ? */
1632         /* FALL THROUGH */
1633     case 'm':
1634         forbid_setid("-m");     /* XXX ? */
1635         if (*++s) {
1636             char *start;
1637             SV *sv;
1638             char *use = "use ";
1639             /* -M-foo == 'no foo'       */
1640             if (*s == '-') { use = "no "; ++s; }
1641             sv = newSVpv(use,0);
1642             start = s;
1643             /* We allow -M'Module qw(Foo Bar)'  */
1644             while(isALNUM(*s) || *s==':') ++s;
1645             if (*s != '=') {
1646                 sv_catpv(sv, start);
1647                 if (*(start-1) == 'm') {
1648                     if (*s != '\0')
1649                         croak("Can't use '%c' after -mname", *s);
1650                     sv_catpv( sv, " ()");
1651                 }
1652             } else {
1653                 sv_catpvn(sv, start, s-start);
1654                 sv_catpv(sv, " split(/,/,q{");
1655                 sv_catpv(sv, ++s);
1656                 sv_catpv(sv,    "})");
1657             }
1658             s += strlen(s);
1659             if (preambleav == NULL)
1660                 preambleav = newAV();
1661             av_push(preambleav, sv);
1662         }
1663         else
1664             croak("No space allowed after -%c", *(s-1));
1665         return s;
1666     case 'n':
1667         minus_n = TRUE;
1668         s++;
1669         return s;
1670     case 'p':
1671         minus_p = TRUE;
1672         s++;
1673         return s;
1674     case 's':
1675         forbid_setid("-s");
1676         doswitches = TRUE;
1677         s++;
1678         return s;
1679     case 'T':
1680         if (!tainting)
1681             croak("Too late for \"-T\" option");
1682         s++;
1683         return s;
1684     case 'u':
1685         do_undump = TRUE;
1686         s++;
1687         return s;
1688     case 'U':
1689         unsafe = TRUE;
1690         s++;
1691         return s;
1692     case 'v':
1693 #if defined(SUBVERSION) && SUBVERSION > 0
1694         printf("\nThis is perl, version 5.%03d_%02d built for %s",
1695             PATCHLEVEL, SUBVERSION, ARCHNAME);
1696 #else
1697         printf("\nThis is perl, version %s built for %s",
1698                 patchlevel, ARCHNAME);
1699 #endif
1700 #if defined(LOCAL_PATCH_COUNT)
1701         if (LOCAL_PATCH_COUNT > 0)
1702             printf("\n(with %d registered patch%s, see perl -V for more detail)",
1703                 LOCAL_PATCH_COUNT, (LOCAL_PATCH_COUNT!=1) ? "es" : "");
1704 #endif
1705
1706         printf("\n\nCopyright 1987-1998, Larry Wall\n");
1707 #ifdef MSDOS
1708         printf("\nMS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n");
1709 #endif
1710 #ifdef DJGPP
1711         printf("djgpp v2 port (jpl5003c) by Hirofumi Watanabe, 1996\n");
1712         printf("djgpp v2 port (perl5004) by Laszlo Molnar, 1997\n");
1713 #endif
1714 #ifdef OS2
1715         printf("\n\nOS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n"
1716             "Version 5 port Copyright (c) 1994-1998, Andreas Kaiser, Ilya Zakharevich\n");
1717 #endif
1718 #ifdef atarist
1719         printf("atariST series port, ++jrb  bammi@cadence.com\n");
1720 #endif
1721         printf("\n\
1722 Perl may be copied only under the terms of either the Artistic License or the\n\
1723 GNU General Public License, which may be found in the Perl 5.0 source kit.\n\n");
1724         PerlProc_exit(0);
1725     case 'w':
1726         dowarn = TRUE;
1727         s++;
1728         return s;
1729     case '*':
1730     case ' ':
1731         if (s[1] == '-')        /* Additional switches on #! line. */
1732             return s+2;
1733         break;
1734     case '-':
1735     case 0:
1736 #ifdef WIN32
1737     case '\r':
1738 #endif
1739     case '\n':
1740     case '\t':
1741         break;
1742 #ifdef ALTERNATE_SHEBANG
1743     case 'S':                   /* OS/2 needs -S on "extproc" line. */
1744         break;
1745 #endif
1746     case 'P':
1747         if (preprocess)
1748             return s+1;
1749         /* FALL THROUGH */
1750     default:
1751         croak("Can't emulate -%.1s on #! line",s);
1752     }
1753     return Nullch;
1754 }
1755
1756 /* compliments of Tom Christiansen */
1757
1758 /* unexec() can be found in the Gnu emacs distribution */
1759
1760 void
1761 my_unexec(void)
1762 {
1763 #ifdef UNEXEC
1764     SV*    prog;
1765     SV*    file;
1766     int    status;
1767     extern int etext;
1768
1769     prog = newSVpv(BIN_EXP);
1770     sv_catpv(prog, "/perl");
1771     file = newSVpv(origfilename);
1772     sv_catpv(file, ".perldump");
1773
1774     status = unexec(SvPVX(file), SvPVX(prog), &etext, sbrk(0), 0);
1775     if (status)
1776         PerlIO_printf(PerlIO_stderr(), "unexec of %s into %s failed!\n",
1777                       SvPVX(prog), SvPVX(file));
1778     PerlProc_exit(status);
1779 #else
1780 #  ifdef VMS
1781 #    include <lib$routines.h>
1782      lib$signal(SS$_DEBUG);  /* ssdef.h #included from vmsish.h */
1783 #  else
1784     ABORT();            /* for use with undump */
1785 #  endif
1786 #endif
1787 }
1788
1789 STATIC void
1790 init_main_stash(void)
1791 {
1792     dTHR;
1793     GV *gv;
1794
1795     /* Note that strtab is a rather special HV.  Assumptions are made
1796        about not iterating on it, and not adding tie magic to it.
1797        It is properly deallocated in perl_destruct() */
1798     strtab = newHV();
1799     HvSHAREKEYS_off(strtab);                    /* mandatory */
1800     Newz(506,((XPVHV*)SvANY(strtab))->xhv_array,
1801          sizeof(HE*) * (((XPVHV*)SvANY(strtab))->xhv_max + 1), char);
1802
1803     curstash = defstash = newHV();
1804     curstname = newSVpv("main",4);
1805     gv = gv_fetchpv("main::",TRUE, SVt_PVHV);
1806     SvREFCNT_dec(GvHV(gv));
1807     GvHV(gv) = (HV*)SvREFCNT_inc(defstash);
1808     SvREADONLY_on(gv);
1809     HvNAME(defstash) = savepv("main");
1810     incgv = gv_HVadd(gv_AVadd(gv_fetchpv("INC",TRUE, SVt_PVAV)));
1811     GvMULTI_on(incgv);
1812     defgv = gv_fetchpv("_",TRUE, SVt_PVAV);
1813     errgv = gv_HVadd(gv_fetchpv("@", TRUE, SVt_PV));
1814     GvMULTI_on(errgv);
1815     (void)form("%240s","");     /* Preallocate temp - for immediate signals. */
1816     sv_grow(ERRSV, 240);        /* Preallocate - for immediate signals. */
1817     sv_setpvn(ERRSV, "", 0);
1818     curstash = defstash;
1819     compiling.cop_stash = defstash;
1820     debstash = GvHV(gv_fetchpv("DB::", GV_ADDMULTI, SVt_PVHV));
1821     globalstash = GvHV(gv_fetchpv("CORE::GLOBAL::", GV_ADDMULTI, SVt_PVHV));
1822     /* We must init $/ before switches are processed. */
1823     sv_setpvn(GvSV(gv_fetchpv("/", TRUE, SVt_PV)), "\n", 1);
1824 }
1825
1826 #ifdef CAN_PROTOTYPE
1827 STATIC void
1828 open_script(char *scriptname, bool dosearch, SV *sv)
1829 #else
1830 STATIC void
1831 open_script(scriptname,dosearch,sv)
1832 char *scriptname;
1833 bool dosearch;
1834 SV *sv;
1835 #endif
1836 {
1837     dTHR;
1838     char *xfound = Nullch;
1839     char *xfailed = Nullch;
1840     register char *s;
1841     I32 len;
1842     int retval;
1843 #if defined(DOSISH) && !defined(OS2) && !defined(atarist)
1844 #  define SEARCH_EXTS ".bat", ".cmd", NULL
1845 #  define MAX_EXT_LEN 4
1846 #endif
1847 #ifdef OS2
1848 #  define SEARCH_EXTS ".cmd", ".btm", ".bat", ".pl", NULL
1849 #  define MAX_EXT_LEN 4
1850 #endif
1851 #ifdef VMS
1852 #  define SEARCH_EXTS ".pl", ".com", NULL
1853 #  define MAX_EXT_LEN 4
1854 #endif
1855     /* additional extensions to try in each dir if scriptname not found */
1856 #ifdef SEARCH_EXTS
1857     char *ext[] = { SEARCH_EXTS };
1858     int extidx = 0, i = 0;
1859     char *curext = Nullch;
1860 #else
1861 #  define MAX_EXT_LEN 0
1862 #endif
1863
1864     /*
1865      * If dosearch is true and if scriptname does not contain path
1866      * delimiters, search the PATH for scriptname.
1867      *
1868      * If SEARCH_EXTS is also defined, will look for each
1869      * scriptname{SEARCH_EXTS} whenever scriptname is not found
1870      * while searching the PATH.
1871      *
1872      * Assuming SEARCH_EXTS is C<".foo",".bar",NULL>, PATH search
1873      * proceeds as follows:
1874      *   If DOSISH or VMSISH:
1875      *     + look for ./scriptname{,.foo,.bar}
1876      *     + search the PATH for scriptname{,.foo,.bar}
1877      *
1878      *   If !DOSISH:
1879      *     + look *only* in the PATH for scriptname{,.foo,.bar} (note
1880      *       this will not look in '.' if it's not in the PATH)
1881      */
1882
1883 #ifdef VMS
1884 #  ifdef ALWAYS_DEFTYPES
1885     len = strlen(scriptname);
1886     if (!(len == 1 && *scriptname == '-') && scriptname[len-1] != ':') {
1887         int hasdir, idx = 0, deftypes = 1;
1888         bool seen_dot = 1;
1889
1890         hasdir = !dosearch || (strpbrk(scriptname,":[</") != Nullch) ;
1891 #  else
1892     if (dosearch) {
1893         int hasdir, idx = 0, deftypes = 1;
1894         bool seen_dot = 1;
1895
1896         hasdir = (strpbrk(scriptname,":[</") != Nullch) ;
1897 #  endif
1898         /* The first time through, just add SEARCH_EXTS to whatever we
1899          * already have, so we can check for default file types. */
1900         while (deftypes ||
1901                (!hasdir && my_trnlnm("DCL$PATH",tokenbuf,idx++)) )
1902         {
1903             if (deftypes) {
1904                 deftypes = 0;
1905                 *tokenbuf = '\0';
1906             }
1907             if ((strlen(tokenbuf) + strlen(scriptname)
1908                  + MAX_EXT_LEN) >= sizeof tokenbuf)
1909                 continue;       /* don't search dir with too-long name */
1910             strcat(tokenbuf, scriptname);
1911 #else  /* !VMS */
1912
1913 #ifdef DOSISH
1914     if (strEQ(scriptname, "-"))
1915         dosearch = 0;
1916     if (dosearch) {             /* Look in '.' first. */
1917         char *cur = scriptname;
1918 #ifdef SEARCH_EXTS
1919         if ((curext = strrchr(scriptname,'.'))) /* possible current ext */
1920             while (ext[i])
1921                 if (strEQ(ext[i++],curext)) {
1922                     extidx = -1;                /* already has an ext */
1923                     break;
1924                 }
1925         do {
1926 #endif
1927             DEBUG_p(PerlIO_printf(Perl_debug_log,
1928                                   "Looking for %s\n",cur));
1929             if (PerlLIO_stat(cur,&statbuf) >= 0) {
1930                 dosearch = 0;
1931                 scriptname = cur;
1932 #ifdef SEARCH_EXTS
1933                 break;
1934 #endif
1935             }
1936 #ifdef SEARCH_EXTS
1937             if (cur == scriptname) {
1938                 len = strlen(scriptname);
1939                 if (len+MAX_EXT_LEN+1 >= sizeof(tokenbuf))
1940                     break;
1941                 cur = strcpy(tokenbuf, scriptname);
1942             }
1943         } while (extidx >= 0 && ext[extidx]     /* try an extension? */
1944                  && strcpy(tokenbuf+len, ext[extidx++]));
1945 #endif
1946     }
1947 #endif
1948
1949     if (dosearch && !strchr(scriptname, '/')
1950 #ifdef DOSISH
1951                  && !strchr(scriptname, '\\')
1952 #endif
1953                  && (s = PerlEnv_getenv("PATH"))) {
1954         bool seen_dot = 0;
1955
1956         bufend = s + strlen(s);
1957         while (s < bufend) {
1958 #if defined(atarist) || defined(DOSISH)
1959             for (len = 0; *s
1960 #  ifdef atarist
1961                     && *s != ','
1962 #  endif
1963                     && *s != ';'; len++, s++) {
1964                 if (len < sizeof tokenbuf)
1965                     tokenbuf[len] = *s;
1966             }
1967             if (len < sizeof tokenbuf)
1968                 tokenbuf[len] = '\0';
1969 #else  /* ! (atarist || DOSISH) */
1970             s = delimcpy(tokenbuf, tokenbuf + sizeof tokenbuf, s, bufend,
1971                         ':',
1972                         &len);
1973 #endif /* ! (atarist || DOSISH) */
1974             if (s < bufend)
1975                 s++;
1976             if (len + 1 + strlen(scriptname) + MAX_EXT_LEN >= sizeof tokenbuf)
1977                 continue;       /* don't search dir with too-long name */
1978             if (len
1979 #if defined(atarist) || defined(DOSISH)
1980                 && tokenbuf[len - 1] != '/'
1981                 && tokenbuf[len - 1] != '\\'
1982 #endif
1983                )
1984                 tokenbuf[len++] = '/';
1985             if (len == 2 && tokenbuf[0] == '.')
1986                 seen_dot = 1;
1987             (void)strcpy(tokenbuf + len, scriptname);
1988 #endif  /* !VMS */
1989
1990 #ifdef SEARCH_EXTS
1991             len = strlen(tokenbuf);
1992             if (extidx > 0)     /* reset after previous loop */
1993                 extidx = 0;
1994             do {
1995 #endif
1996                 DEBUG_p(PerlIO_printf(Perl_debug_log, "Looking for %s\n",tokenbuf));
1997                 retval = PerlLIO_stat(tokenbuf,&statbuf);
1998 #ifdef SEARCH_EXTS
1999             } while (  retval < 0               /* not there */
2000                     && extidx>=0 && ext[extidx] /* try an extension? */
2001                     && strcpy(tokenbuf+len, ext[extidx++])
2002                 );
2003 #endif
2004             if (retval < 0)
2005                 continue;
2006             if (S_ISREG(statbuf.st_mode)
2007                 && cando(S_IRUSR,TRUE,&statbuf)
2008 #ifndef DOSISH
2009                 && cando(S_IXUSR,TRUE,&statbuf)
2010 #endif
2011                 )
2012             {
2013                 xfound = tokenbuf;              /* bingo! */
2014                 break;
2015             }
2016             if (!xfailed)
2017                 xfailed = savepv(tokenbuf);
2018         }
2019 #ifndef DOSISH
2020         if (!xfound && !seen_dot && !xfailed && (PerlLIO_stat(scriptname,&statbuf) < 0))
2021 #endif
2022             seen_dot = 1;                       /* Disable message. */
2023         if (!xfound)
2024             croak("Can't %s %s%s%s",
2025                   (xfailed ? "execute" : "find"),
2026                   (xfailed ? xfailed : scriptname),
2027                   (xfailed ? "" : " on PATH"),
2028                   (xfailed || seen_dot) ? "" : ", '.' not in PATH");
2029         if (xfailed)
2030             Safefree(xfailed);
2031         scriptname = xfound;
2032     }
2033
2034     if (strnEQ(scriptname, "/dev/fd/", 8) && isDIGIT(scriptname[8]) ) {
2035         char *s = scriptname + 8;
2036         fdscript = atoi(s);
2037         while (isDIGIT(*s))
2038             s++;
2039         if (*s)
2040             scriptname = s + 1;
2041     }
2042     else
2043         fdscript = -1;
2044     origfilename = savepv(e_tmpname ? "-e" : scriptname);
2045     curcop->cop_filegv = gv_fetchfile(origfilename);
2046     if (strEQ(origfilename,"-"))
2047         scriptname = "";
2048     if (fdscript >= 0) {
2049         rsfp = PerlIO_fdopen(fdscript,PERL_SCRIPT_MODE);
2050 #if defined(HAS_FCNTL) && defined(F_SETFD)
2051         if (rsfp)
2052             fcntl(PerlIO_fileno(rsfp),F_SETFD,1);  /* ensure close-on-exec */
2053 #endif
2054     }
2055     else if (preprocess) {
2056         char *cpp_cfg = CPPSTDIN;
2057         SV *cpp = NEWSV(0,0);
2058         SV *cmd = NEWSV(0,0);
2059
2060         if (strEQ(cpp_cfg, "cppstdin"))
2061             sv_catpvf(cpp, "%s/", BIN_EXP);
2062         sv_catpv(cpp, cpp_cfg);
2063
2064         sv_catpv(sv,"-I");
2065         sv_catpv(sv,PRIVLIB_EXP);
2066
2067 #ifdef MSDOS
2068         sv_setpvf(cmd, "\
2069 sed %s -e \"/^[^#]/b\" \
2070  -e \"/^#[      ]*include[      ]/b\" \
2071  -e \"/^#[      ]*define[       ]/b\" \
2072  -e \"/^#[      ]*if[   ]/b\" \
2073  -e \"/^#[      ]*ifdef[        ]/b\" \
2074  -e \"/^#[      ]*ifndef[       ]/b\" \
2075  -e \"/^#[      ]*else/b\" \
2076  -e \"/^#[      ]*elif[         ]/b\" \
2077  -e \"/^#[      ]*undef[        ]/b\" \
2078  -e \"/^#[      ]*endif/b\" \
2079  -e \"s/^#.*//\" \
2080  %s | %_ -C %_ %s",
2081           (doextract ? "-e \"1,/^#/d\n\"" : ""),
2082 #else
2083         sv_setpvf(cmd, "\
2084 %s %s -e '/^[^#]/b' \
2085  -e '/^#[       ]*include[      ]/b' \
2086  -e '/^#[       ]*define[       ]/b' \
2087  -e '/^#[       ]*if[   ]/b' \
2088  -e '/^#[       ]*ifdef[        ]/b' \
2089  -e '/^#[       ]*ifndef[       ]/b' \
2090  -e '/^#[       ]*else/b' \
2091  -e '/^#[       ]*elif[         ]/b' \
2092  -e '/^#[       ]*undef[        ]/b' \
2093  -e '/^#[       ]*endif/b' \
2094  -e 's/^[       ]*#.*//' \
2095  %s | %_ -C %_ %s",
2096 #ifdef LOC_SED
2097           LOC_SED,
2098 #else
2099           "sed",
2100 #endif
2101           (doextract ? "-e '1,/^#/d\n'" : ""),
2102 #endif
2103           scriptname, cpp, sv, CPPMINUS);
2104         doextract = FALSE;
2105 #ifdef IAMSUID                          /* actually, this is caught earlier */
2106         if (euid != uid && !euid) {     /* if running suidperl */
2107 #ifdef HAS_SETEUID
2108             (void)seteuid(uid);         /* musn't stay setuid root */
2109 #else
2110 #ifdef HAS_SETREUID
2111             (void)setreuid((Uid_t)-1, uid);
2112 #else
2113 #ifdef HAS_SETRESUID
2114             (void)setresuid((Uid_t)-1, uid, (Uid_t)-1);
2115 #else
2116             PerlProc_setuid(uid);
2117 #endif
2118 #endif
2119 #endif
2120             if (PerlProc_geteuid() != uid)
2121                 croak("Can't do seteuid!\n");
2122         }
2123 #endif /* IAMSUID */
2124         rsfp = PerlProc_popen(SvPVX(cmd), "r");
2125         SvREFCNT_dec(cmd);
2126         SvREFCNT_dec(cpp);
2127     }
2128     else if (!*scriptname) {
2129         forbid_setid("program input from stdin");
2130         rsfp = PerlIO_stdin();
2131     }
2132     else {
2133         rsfp = PerlIO_open(scriptname,PERL_SCRIPT_MODE);
2134 #if defined(HAS_FCNTL) && defined(F_SETFD)
2135         if (rsfp)
2136             fcntl(PerlIO_fileno(rsfp),F_SETFD,1);  /* ensure close-on-exec */
2137 #endif
2138     }
2139     if (e_tmpname) {
2140         e_fp = rsfp;
2141     }
2142     if (!rsfp) {
2143 #ifdef DOSUID
2144 #ifndef IAMSUID         /* in case script is not readable before setuid */
2145         if (euid && PerlLIO_stat(SvPVX(GvSV(curcop->cop_filegv)),&statbuf) >= 0 &&
2146           statbuf.st_mode & (S_ISUID|S_ISGID)) {
2147             /* try again */
2148             PerlProc_execv(form("%s/sperl%s", BIN_EXP, patchlevel), origargv);
2149             croak("Can't do setuid\n");
2150         }
2151 #endif
2152 #endif
2153         croak("Can't open perl script \"%s\": %s\n",
2154           SvPVX(GvSV(curcop->cop_filegv)), Strerror(errno));
2155     }
2156 }
2157
2158 STATIC void
2159 validate_suid(char *validarg, char *scriptname)
2160 {
2161     int which;
2162
2163     /* do we need to emulate setuid on scripts? */
2164
2165     /* This code is for those BSD systems that have setuid #! scripts disabled
2166      * in the kernel because of a security problem.  Merely defining DOSUID
2167      * in perl will not fix that problem, but if you have disabled setuid
2168      * scripts in the kernel, this will attempt to emulate setuid and setgid
2169      * on scripts that have those now-otherwise-useless bits set.  The setuid
2170      * root version must be called suidperl or sperlN.NNN.  If regular perl
2171      * discovers that it has opened a setuid script, it calls suidperl with
2172      * the same argv that it had.  If suidperl finds that the script it has
2173      * just opened is NOT setuid root, it sets the effective uid back to the
2174      * uid.  We don't just make perl setuid root because that loses the
2175      * effective uid we had before invoking perl, if it was different from the
2176      * uid.
2177      *
2178      * DOSUID must be defined in both perl and suidperl, and IAMSUID must
2179      * be defined in suidperl only.  suidperl must be setuid root.  The
2180      * Configure script will set this up for you if you want it.
2181      */
2182
2183 #ifdef DOSUID
2184     dTHR;
2185     char *s, *s2;
2186
2187     if (PerlLIO_fstat(PerlIO_fileno(rsfp),&statbuf) < 0)        /* normal stat is insecure */
2188         croak("Can't stat script \"%s\"",origfilename);
2189     if (fdscript < 0 && statbuf.st_mode & (S_ISUID|S_ISGID)) {
2190         I32 len;
2191
2192 #ifdef IAMSUID
2193 #ifndef HAS_SETREUID
2194         /* On this access check to make sure the directories are readable,
2195          * there is actually a small window that the user could use to make
2196          * filename point to an accessible directory.  So there is a faint
2197          * chance that someone could execute a setuid script down in a
2198          * non-accessible directory.  I don't know what to do about that.
2199          * But I don't think it's too important.  The manual lies when
2200          * it says access() is useful in setuid programs.
2201          */
2202         if (PerlLIO_access(SvPVX(GvSV(curcop->cop_filegv)),1))  /*double check*/
2203             croak("Permission denied");
2204 #else
2205         /* If we can swap euid and uid, then we can determine access rights
2206          * with a simple stat of the file, and then compare device and
2207          * inode to make sure we did stat() on the same file we opened.
2208          * Then we just have to make sure he or she can execute it.
2209          */
2210         {
2211             struct stat tmpstatbuf;
2212
2213             if (
2214 #ifdef HAS_SETREUID
2215                 setreuid(euid,uid) < 0
2216 #else
2217 # if HAS_SETRESUID
2218                 setresuid(euid,uid,(Uid_t)-1) < 0
2219 # endif
2220 #endif
2221                 || PerlProc_getuid() != euid || PerlProc_geteuid() != uid)
2222                 croak("Can't swap uid and euid");       /* really paranoid */
2223             if (PerlLIO_stat(SvPVX(GvSV(curcop->cop_filegv)),&tmpstatbuf) < 0)
2224                 croak("Permission denied");     /* testing full pathname here */
2225             if (tmpstatbuf.st_dev != statbuf.st_dev ||
2226                 tmpstatbuf.st_ino != statbuf.st_ino) {
2227                 (void)PerlIO_close(rsfp);
2228                 if (rsfp = PerlProc_popen("/bin/mail root","w")) {      /* heh, heh */
2229                     PerlIO_printf(rsfp,
2230 "User %ld tried to run dev %ld ino %ld in place of dev %ld ino %ld!\n\
2231 (Filename of set-id script was %s, uid %ld gid %ld.)\n\nSincerely,\nperl\n",
2232                         (long)uid,(long)tmpstatbuf.st_dev, (long)tmpstatbuf.st_ino,
2233                         (long)statbuf.st_dev, (long)statbuf.st_ino,
2234                         SvPVX(GvSV(curcop->cop_filegv)),
2235                         (long)statbuf.st_uid, (long)statbuf.st_gid);
2236                     (void)PerlProc_pclose(rsfp);
2237                 }
2238                 croak("Permission denied\n");
2239             }
2240             if (
2241 #ifdef HAS_SETREUID
2242               setreuid(uid,euid) < 0
2243 #else
2244 # if defined(HAS_SETRESUID)
2245               setresuid(uid,euid,(Uid_t)-1) < 0
2246 # endif
2247 #endif
2248               || PerlProc_getuid() != uid || PerlProc_geteuid() != euid)
2249                 croak("Can't reswap uid and euid");
2250             if (!cando(S_IXUSR,FALSE,&statbuf))         /* can real uid exec? */
2251                 croak("Permission denied\n");
2252         }
2253 #endif /* HAS_SETREUID */
2254 #endif /* IAMSUID */
2255
2256         if (!S_ISREG(statbuf.st_mode))
2257             croak("Permission denied");
2258         if (statbuf.st_mode & S_IWOTH)
2259             croak("Setuid/gid script is writable by world");
2260         doswitches = FALSE;             /* -s is insecure in suid */
2261         curcop->cop_line++;
2262         if (sv_gets(linestr, rsfp, 0) == Nullch ||
2263           strnNE(SvPV(linestr,na),"#!",2) )     /* required even on Sys V */
2264             croak("No #! line");
2265         s = SvPV(linestr,na)+2;
2266         if (*s == ' ') s++;
2267         while (!isSPACE(*s)) s++;
2268         for (s2 = s;  (s2 > SvPV(linestr,na)+2 &&
2269                        (isDIGIT(s2[-1]) || strchr("._-", s2[-1])));  s2--) ;
2270         if (strnNE(s2-4,"perl",4) && strnNE(s-9,"perl",4))  /* sanity check */
2271             croak("Not a perl script");
2272         while (*s == ' ' || *s == '\t') s++;
2273         /*
2274          * #! arg must be what we saw above.  They can invoke it by
2275          * mentioning suidperl explicitly, but they may not add any strange
2276          * arguments beyond what #! says if they do invoke suidperl that way.
2277          */
2278         len = strlen(validarg);
2279         if (strEQ(validarg," PHOOEY ") ||
2280             strnNE(s,validarg,len) || !isSPACE(s[len]))
2281             croak("Args must match #! line");
2282
2283 #ifndef IAMSUID
2284         if (euid != uid && (statbuf.st_mode & S_ISUID) &&
2285             euid == statbuf.st_uid)
2286             if (!do_undump)
2287                 croak("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
2288 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
2289 #endif /* IAMSUID */
2290
2291         if (euid) {     /* oops, we're not the setuid root perl */
2292             (void)PerlIO_close(rsfp);
2293 #ifndef IAMSUID
2294             /* try again */
2295             PerlProc_execv(form("%s/sperl%s", BIN_EXP, patchlevel), origargv);
2296 #endif
2297             croak("Can't do setuid\n");
2298         }
2299
2300         if (statbuf.st_mode & S_ISGID && statbuf.st_gid != egid) {
2301 #ifdef HAS_SETEGID
2302             (void)setegid(statbuf.st_gid);
2303 #else
2304 #ifdef HAS_SETREGID
2305            (void)setregid((Gid_t)-1,statbuf.st_gid);
2306 #else
2307 #ifdef HAS_SETRESGID
2308            (void)setresgid((Gid_t)-1,statbuf.st_gid,(Gid_t)-1);
2309 #else
2310             PerlProc_setgid(statbuf.st_gid);
2311 #endif
2312 #endif
2313 #endif
2314             if (PerlProc_getegid() != statbuf.st_gid)
2315                 croak("Can't do setegid!\n");
2316         }
2317         if (statbuf.st_mode & S_ISUID) {
2318             if (statbuf.st_uid != euid)
2319 #ifdef HAS_SETEUID
2320                 (void)seteuid(statbuf.st_uid);  /* all that for this */
2321 #else
2322 #ifdef HAS_SETREUID
2323                 (void)setreuid((Uid_t)-1,statbuf.st_uid);
2324 #else
2325 #ifdef HAS_SETRESUID
2326                 (void)setresuid((Uid_t)-1,statbuf.st_uid,(Uid_t)-1);
2327 #else
2328                 PerlProc_setuid(statbuf.st_uid);
2329 #endif
2330 #endif
2331 #endif
2332             if (PerlProc_geteuid() != statbuf.st_uid)
2333                 croak("Can't do seteuid!\n");
2334         }
2335         else if (uid) {                 /* oops, mustn't run as root */
2336 #ifdef HAS_SETEUID
2337           (void)seteuid((Uid_t)uid);
2338 #else
2339 #ifdef HAS_SETREUID
2340           (void)setreuid((Uid_t)-1,(Uid_t)uid);
2341 #else
2342 #ifdef HAS_SETRESUID
2343           (void)setresuid((Uid_t)-1,(Uid_t)uid,(Uid_t)-1);
2344 #else
2345           PerlProc_setuid((Uid_t)uid);
2346 #endif
2347 #endif
2348 #endif
2349             if (PerlProc_geteuid() != uid)
2350                 croak("Can't do seteuid!\n");
2351         }
2352         init_ids();
2353         if (!cando(S_IXUSR,TRUE,&statbuf))
2354             croak("Permission denied\n");       /* they can't do this */
2355     }
2356 #ifdef IAMSUID
2357     else if (preprocess)
2358         croak("-P not allowed for setuid/setgid script\n");
2359     else if (fdscript >= 0)
2360         croak("fd script not allowed in suidperl\n");
2361     else
2362         croak("Script is not setuid/setgid in suidperl\n");
2363
2364     /* We absolutely must clear out any saved ids here, so we */
2365     /* exec the real perl, substituting fd script for scriptname. */
2366     /* (We pass script name as "subdir" of fd, which perl will grok.) */
2367     PerlIO_rewind(rsfp);
2368     PerlLIO_lseek(PerlIO_fileno(rsfp),(Off_t)0,0);  /* just in case rewind didn't */
2369     for (which = 1; origargv[which] && origargv[which] != scriptname; which++) ;
2370     if (!origargv[which])
2371         croak("Permission denied");
2372     origargv[which] = savepv(form("/dev/fd/%d/%s",
2373                                   PerlIO_fileno(rsfp), origargv[which]));
2374 #if defined(HAS_FCNTL) && defined(F_SETFD)
2375     fcntl(PerlIO_fileno(rsfp),F_SETFD,0);       /* ensure no close-on-exec */
2376 #endif
2377     PerlProc_execv(form("%s/perl%s", BIN_EXP, patchlevel), origargv);   /* try again */
2378     croak("Can't do setuid\n");
2379 #endif /* IAMSUID */
2380 #else /* !DOSUID */
2381     if (euid != uid || egid != gid) {   /* (suidperl doesn't exist, in fact) */
2382 #ifndef SETUID_SCRIPTS_ARE_SECURE_NOW
2383         dTHR;
2384         PerlLIO_fstat(PerlIO_fileno(rsfp),&statbuf);    /* may be either wrapped or real suid */
2385         if ((euid != uid && euid == statbuf.st_uid && statbuf.st_mode & S_ISUID)
2386             ||
2387             (egid != gid && egid == statbuf.st_gid && statbuf.st_mode & S_ISGID)
2388            )
2389             if (!do_undump)
2390                 croak("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
2391 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
2392 #endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
2393         /* not set-id, must be wrapped */
2394     }
2395 #endif /* DOSUID */
2396 }
2397
2398 STATIC void
2399 find_beginning(void)
2400 {
2401     register char *s, *s2;
2402
2403     /* skip forward in input to the real script? */
2404
2405     forbid_setid("-x");
2406     while (doextract) {
2407         if ((s = sv_gets(linestr, rsfp, 0)) == Nullch)
2408             croak("No Perl script found in input\n");
2409         if (*s == '#' && s[1] == '!' && (s = instr(s,"perl"))) {
2410             PerlIO_ungetc(rsfp, '\n');          /* to keep line count right */
2411             doextract = FALSE;
2412             while (*s && !(isSPACE (*s) || *s == '#')) s++;
2413             s2 = s;
2414             while (*s == ' ' || *s == '\t') s++;
2415             if (*s++ == '-') {
2416                 while (isDIGIT(s2[-1]) || strchr("-._", s2[-1])) s2--;
2417                 if (strnEQ(s2-4,"perl",4))
2418                     /*SUPPRESS 530*/
2419                     while (s = moreswitches(s)) ;
2420             }
2421             if (cddir && PerlDir_chdir(cddir) < 0)
2422                 croak("Can't chdir to %s",cddir);
2423         }
2424     }
2425 }
2426
2427 STATIC void
2428 init_ids(void)
2429 {
2430     uid = (int)PerlProc_getuid();
2431     euid = (int)PerlProc_geteuid();
2432     gid = (int)PerlProc_getgid();
2433     egid = (int)PerlProc_getegid();
2434 #ifdef VMS
2435     uid |= gid << 16;
2436     euid |= egid << 16;
2437 #endif
2438     tainting |= (uid && (euid != uid || egid != gid));
2439 }
2440
2441 STATIC void
2442 forbid_setid(char *s)
2443 {
2444     if (euid != uid)
2445         croak("No %s allowed while running setuid", s);
2446     if (egid != gid)
2447         croak("No %s allowed while running setgid", s);
2448 }
2449
2450 STATIC void
2451 init_debugger(void)
2452 {
2453     dTHR;
2454     curstash = debstash;
2455     dbargs = GvAV(gv_AVadd((gv_fetchpv("args", GV_ADDMULTI, SVt_PVAV))));
2456     AvREAL_off(dbargs);
2457     DBgv = gv_fetchpv("DB", GV_ADDMULTI, SVt_PVGV);
2458     DBline = gv_fetchpv("dbline", GV_ADDMULTI, SVt_PVAV);
2459     DBsub = gv_HVadd(gv_fetchpv("sub", GV_ADDMULTI, SVt_PVHV));
2460     DBsingle = GvSV((gv_fetchpv("single", GV_ADDMULTI, SVt_PV)));
2461     sv_setiv(DBsingle, 0);
2462     DBtrace = GvSV((gv_fetchpv("trace", GV_ADDMULTI, SVt_PV)));
2463     sv_setiv(DBtrace, 0);
2464     DBsignal = GvSV((gv_fetchpv("signal", GV_ADDMULTI, SVt_PV)));
2465     sv_setiv(DBsignal, 0);
2466     curstash = defstash;
2467 }
2468
2469 void
2470 init_stacks(ARGSproto)
2471 {
2472     curstack = newAV();
2473     mainstack = curstack;               /* remember in case we switch stacks */
2474     AvREAL_off(curstack);               /* not a real array */
2475     av_extend(curstack,127);
2476
2477     stack_base = AvARRAY(curstack);
2478     stack_sp = stack_base;
2479     stack_max = stack_base + 127;
2480
2481     cxstack_max = 8192 / sizeof(PERL_CONTEXT) - 2;      /* Use most of 8K. */
2482     New(50,cxstack,cxstack_max + 1,PERL_CONTEXT);
2483     cxstack_ix  = -1;
2484
2485     New(50,tmps_stack,128,SV*);
2486     tmps_floor = -1;
2487     tmps_ix = -1;
2488     tmps_max = 128;
2489
2490     /*
2491      * The following stacks almost certainly should be per-interpreter,
2492      * but for now they're not.  XXX
2493      */
2494
2495     if (markstack) {
2496         markstack_ptr = markstack;
2497     } else {
2498         New(54,markstack,64,I32);
2499         markstack_ptr = markstack;
2500         markstack_max = markstack + 64;
2501     }
2502
2503     if (scopestack) {
2504         scopestack_ix = 0;
2505     } else {
2506         New(54,scopestack,32,I32);
2507         scopestack_ix = 0;
2508         scopestack_max = 32;
2509     }
2510
2511     if (savestack) {
2512         savestack_ix = 0;
2513     } else {
2514         New(54,savestack,128,ANY);
2515         savestack_ix = 0;
2516         savestack_max = 128;
2517     }
2518
2519     if (retstack) {
2520         retstack_ix = 0;
2521     } else {
2522         New(54,retstack,16,OP*);
2523         retstack_ix = 0;
2524         retstack_max = 16;
2525     }
2526 }
2527
2528 STATIC void
2529 nuke_stacks(void)
2530 {
2531     dTHR;
2532     Safefree(cxstack);
2533     Safefree(tmps_stack);
2534     DEBUG( {
2535         Safefree(debname);
2536         Safefree(debdelim);
2537     } )
2538 }
2539
2540 #ifndef PERL_OBJECT
2541 static PerlIO *tmpfp;  /* moved outside init_lexer() because of UNICOS bug */
2542 #endif
2543
2544 STATIC void
2545 init_lexer(void)
2546 {
2547 #ifdef PERL_OBJECT
2548         PerlIO *tmpfp;
2549 #endif
2550     tmpfp = rsfp;
2551     rsfp = Nullfp;
2552     lex_start(linestr);
2553     rsfp = tmpfp;
2554     subname = newSVpv("main",4);
2555 }
2556
2557 STATIC void
2558 init_predump_symbols(void)
2559 {
2560     dTHR;
2561     GV *tmpgv;
2562     GV *othergv;
2563
2564     sv_setpvn(perl_get_sv("\"", TRUE), " ", 1);
2565     stdingv = gv_fetchpv("STDIN",TRUE, SVt_PVIO);
2566     GvMULTI_on(stdingv);
2567     IoIFP(GvIOp(stdingv)) = PerlIO_stdin();
2568     tmpgv = gv_fetchpv("stdin",TRUE, SVt_PV);
2569     GvMULTI_on(tmpgv);
2570     GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(stdingv));
2571
2572     tmpgv = gv_fetchpv("STDOUT",TRUE, SVt_PVIO);
2573     GvMULTI_on(tmpgv);
2574     IoOFP(GvIOp(tmpgv)) = IoIFP(GvIOp(tmpgv)) = PerlIO_stdout();
2575     setdefout(tmpgv);
2576     tmpgv = gv_fetchpv("stdout",TRUE, SVt_PV);
2577     GvMULTI_on(tmpgv);
2578     GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(defoutgv));
2579
2580     othergv = gv_fetchpv("STDERR",TRUE, SVt_PVIO);
2581     GvMULTI_on(othergv);
2582     IoOFP(GvIOp(othergv)) = IoIFP(GvIOp(othergv)) = PerlIO_stderr();
2583     tmpgv = gv_fetchpv("stderr",TRUE, SVt_PV);
2584     GvMULTI_on(tmpgv);
2585     GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(othergv));
2586
2587     statname = NEWSV(66,0);             /* last filename we did stat on */
2588
2589     if (!osname)
2590         osname = savepv(OSNAME);
2591 }
2592
2593 STATIC void
2594 init_postdump_symbols(register int argc, register char **argv, register char **env)
2595 {
2596     dTHR;
2597     char *s;
2598     SV *sv;
2599     GV* tmpgv;
2600
2601     argc--,argv++;      /* skip name of script */
2602     if (doswitches) {
2603         for (; argc > 0 && **argv == '-'; argc--,argv++) {
2604             if (!argv[0][1])
2605                 break;
2606             if (argv[0][1] == '-') {
2607                 argc--,argv++;
2608                 break;
2609             }
2610             if (s = strchr(argv[0], '=')) {
2611                 *s++ = '\0';
2612                 sv_setpv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),s);
2613             }
2614             else
2615                 sv_setiv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),1);
2616         }
2617     }
2618     toptarget = NEWSV(0,0);
2619     sv_upgrade(toptarget, SVt_PVFM);
2620     sv_setpvn(toptarget, "", 0);
2621     bodytarget = NEWSV(0,0);
2622     sv_upgrade(bodytarget, SVt_PVFM);
2623     sv_setpvn(bodytarget, "", 0);
2624     formtarget = bodytarget;
2625
2626     TAINT;
2627     if (tmpgv = gv_fetchpv("0",TRUE, SVt_PV)) {
2628         sv_setpv(GvSV(tmpgv),origfilename);
2629         magicname("0", "0", 1);
2630     }
2631     if (tmpgv = gv_fetchpv("\030",TRUE, SVt_PV))
2632         sv_setpv(GvSV(tmpgv),origargv[0]);
2633     if (argvgv = gv_fetchpv("ARGV",TRUE, SVt_PVAV)) {
2634         GvMULTI_on(argvgv);
2635         (void)gv_AVadd(argvgv);
2636         av_clear(GvAVn(argvgv));
2637         for (; argc > 0; argc--,argv++) {
2638             av_push(GvAVn(argvgv),newSVpv(argv[0],0));
2639         }
2640     }
2641     if (envgv = gv_fetchpv("ENV",TRUE, SVt_PVHV)) {
2642         HV *hv;
2643         GvMULTI_on(envgv);
2644         hv = GvHVn(envgv);
2645         hv_magic(hv, envgv, 'E');
2646 #ifndef VMS  /* VMS doesn't have environ array */
2647         /* Note that if the supplied env parameter is actually a copy
2648            of the global environ then it may now point to free'd memory
2649            if the environment has been modified since. To avoid this
2650            problem we treat env==NULL as meaning 'use the default'
2651         */
2652         if (!env)
2653             env = environ;
2654         if (env != environ)
2655             environ[0] = Nullch;
2656         for (; *env; env++) {
2657             if (!(s = strchr(*env,'=')))
2658                 continue;
2659             *s++ = '\0';
2660 #if defined(WIN32) || defined(MSDOS)
2661             (void)strupr(*env);
2662 #endif
2663             sv = newSVpv(s--,0);
2664             (void)hv_store(hv, *env, s - *env, sv, 0);
2665             *s = '=';
2666 #if defined(__BORLANDC__) && defined(USE_WIN32_RTL_ENV)
2667             /* Sins of the RTL. See note in my_setenv(). */
2668             (void)PerlEnv_putenv(savepv(*env));
2669 #endif
2670         }
2671 #endif
2672 #ifdef DYNAMIC_ENV_FETCH
2673         HvNAME(hv) = savepv(ENV_HV_NAME);
2674 #endif
2675     }
2676     TAINT_NOT;
2677     if (tmpgv = gv_fetchpv("$",TRUE, SVt_PV))
2678         sv_setiv(GvSV(tmpgv), (IV)getpid());
2679 }
2680
2681 STATIC void
2682 init_perllib(void)
2683 {
2684     char *s;
2685     if (!tainting) {
2686 #ifndef VMS
2687         s = PerlEnv_getenv("PERL5LIB");
2688         if (s)
2689             incpush(s, TRUE);
2690         else
2691             incpush(PerlEnv_getenv("PERLLIB"), FALSE);
2692 #else /* VMS */
2693         /* Treat PERL5?LIB as a possible search list logical name -- the
2694          * "natural" VMS idiom for a Unix path string.  We allow each
2695          * element to be a set of |-separated directories for compatibility.
2696          */
2697         char buf[256];
2698         int idx = 0;
2699         if (my_trnlnm("PERL5LIB",buf,0))
2700             do { incpush(buf,TRUE); } while (my_trnlnm("PERL5LIB",buf,++idx));
2701         else
2702             while (my_trnlnm("PERLLIB",buf,idx++)) incpush(buf,FALSE);
2703 #endif /* VMS */
2704     }
2705
2706 /* Use the ~-expanded versions of APPLLIB (undocumented),
2707     ARCHLIB PRIVLIB SITEARCH SITELIB and OLDARCHLIB
2708 */
2709 #ifdef APPLLIB_EXP
2710     incpush(APPLLIB_EXP, FALSE);
2711 #endif
2712
2713 #ifdef ARCHLIB_EXP
2714     incpush(ARCHLIB_EXP, FALSE);
2715 #endif
2716 #ifndef PRIVLIB_EXP
2717 #define PRIVLIB_EXP "/usr/local/lib/perl5:/usr/local/lib/perl"
2718 #endif
2719     incpush(PRIVLIB_EXP, FALSE);
2720
2721 #ifdef SITEARCH_EXP
2722     incpush(SITEARCH_EXP, FALSE);
2723 #endif
2724 #ifdef SITELIB_EXP
2725     incpush(SITELIB_EXP, FALSE);
2726 #endif
2727 #ifdef OLDARCHLIB_EXP  /* 5.00[01] compatibility */
2728     incpush(OLDARCHLIB_EXP, FALSE);
2729 #endif
2730
2731     if (!tainting)
2732         incpush(".", FALSE);
2733 }
2734
2735 #if defined(DOSISH)
2736 #    define PERLLIB_SEP ';'
2737 #else
2738 #  if defined(VMS)
2739 #    define PERLLIB_SEP '|'
2740 #  else
2741 #    define PERLLIB_SEP ':'
2742 #  endif
2743 #endif
2744 #ifndef PERLLIB_MANGLE
2745 #  define PERLLIB_MANGLE(s,n) (s)
2746 #endif
2747
2748 STATIC void
2749 incpush(char *p, int addsubdirs)
2750 {
2751     SV *subdir = Nullsv;
2752
2753     if (!p)
2754         return;
2755
2756     if (addsubdirs) {
2757         subdir = NEWSV(55,0);
2758         if (!archpat_auto) {
2759             STRLEN len = (sizeof(ARCHNAME) + strlen(patchlevel)
2760                           + sizeof("//auto"));
2761             New(55, archpat_auto, len, char);
2762             sprintf(archpat_auto, "/%s/%s/auto", ARCHNAME, patchlevel);
2763 #ifdef VMS
2764         for (len = sizeof(ARCHNAME) + 2;
2765              archpat_auto[len] != '\0' && archpat_auto[len] != '/'; len++)
2766                 if (archpat_auto[len] == '.') archpat_auto[len] = '_';
2767 #endif
2768         }
2769     }
2770
2771     /* Break at all separators */
2772     while (p && *p) {
2773         SV *libdir = NEWSV(55,0);
2774         char *s;
2775
2776         /* skip any consecutive separators */
2777         while ( *p == PERLLIB_SEP ) {
2778             /* Uncomment the next line for PATH semantics */
2779             /* av_push(GvAVn(incgv), newSVpv(".", 1)); */
2780             p++;
2781         }
2782
2783         if ( (s = strchr(p, PERLLIB_SEP)) != Nullch ) {
2784             sv_setpvn(libdir, PERLLIB_MANGLE(p, (STRLEN)(s - p)),
2785                       (STRLEN)(s - p));
2786             p = s + 1;
2787         }
2788         else {
2789             sv_setpv(libdir, PERLLIB_MANGLE(p, 0));
2790             p = Nullch; /* break out */
2791         }
2792
2793         /*
2794          * BEFORE pushing libdir onto @INC we may first push version- and
2795          * archname-specific sub-directories.
2796          */
2797         if (addsubdirs) {
2798             struct stat tmpstatbuf;
2799 #ifdef VMS
2800             char *unix;
2801             STRLEN len;
2802
2803             if ((unix = tounixspec_ts(SvPV(libdir,na),Nullch)) != Nullch) {
2804                 len = strlen(unix);
2805                 while (unix[len-1] == '/') len--;  /* Cosmetic */
2806                 sv_usepvn(libdir,unix,len);
2807             }
2808             else
2809                 PerlIO_printf(PerlIO_stderr(),
2810                               "Failed to unixify @INC element \"%s\"\n",
2811                               SvPV(libdir,na));
2812 #endif
2813             /* .../archname/version if -d .../archname/version/auto */
2814             sv_setsv(subdir, libdir);
2815             sv_catpv(subdir, archpat_auto);
2816             if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
2817                   S_ISDIR(tmpstatbuf.st_mode))
2818                 av_push(GvAVn(incgv),
2819                         newSVpv(SvPVX(subdir), SvCUR(subdir) - sizeof "auto"));
2820
2821             /* .../archname if -d .../archname/auto */
2822             sv_insert(subdir, SvCUR(libdir) + sizeof(ARCHNAME),
2823                       strlen(patchlevel) + 1, "", 0);
2824             if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
2825                   S_ISDIR(tmpstatbuf.st_mode))
2826                 av_push(GvAVn(incgv),
2827                         newSVpv(SvPVX(subdir), SvCUR(subdir) - sizeof "auto"));
2828         }
2829
2830         /* finally push this lib directory on the end of @INC */
2831         av_push(GvAVn(incgv), libdir);
2832     }
2833
2834     SvREFCNT_dec(subdir);
2835 }
2836
2837 #ifdef USE_THREADS
2838 STATIC struct perl_thread *
2839 init_main_thread()
2840 {
2841     struct perl_thread *thr;
2842     XPV *xpv;
2843
2844     Newz(53, thr, 1, struct perl_thread);
2845     curcop = &compiling;
2846     thr->cvcache = newHV();
2847     thr->threadsv = newAV();
2848     /* thr->threadsvp is set when find_threadsv is called */
2849     thr->specific = newAV();
2850     thr->errhv = newHV();
2851     thr->flags = THRf_R_JOINABLE;
2852     MUTEX_INIT(&thr->mutex);
2853     /* Handcraft thrsv similarly to mess_sv */
2854     New(53, thrsv, 1, SV);
2855     Newz(53, xpv, 1, XPV);
2856     SvFLAGS(thrsv) = SVt_PV;
2857     SvANY(thrsv) = (void*)xpv;
2858     SvREFCNT(thrsv) = 1 << 30;  /* practically infinite */
2859     SvPVX(thrsv) = (char*)thr;
2860     SvCUR_set(thrsv, sizeof(thr));
2861     SvLEN_set(thrsv, sizeof(thr));
2862     *SvEND(thrsv) = '\0';       /* in the trailing_nul field */
2863     thr->oursv = thrsv;
2864     curcop = &compiling;
2865     chopset = " \n-";
2866
2867     MUTEX_LOCK(&threads_mutex);
2868     nthreads++;
2869     thr->tid = 0;
2870     thr->next = thr;
2871     thr->prev = thr;
2872     MUTEX_UNLOCK(&threads_mutex);
2873
2874 #ifdef HAVE_THREAD_INTERN
2875     init_thread_intern(thr);
2876 #endif
2877
2878 #ifdef SET_THREAD_SELF
2879     SET_THREAD_SELF(thr);
2880 #else
2881     thr->self = pthread_self();
2882 #endif /* SET_THREAD_SELF */
2883     SET_THR(thr);
2884
2885     /*
2886      * These must come after the SET_THR because sv_setpvn does
2887      * SvTAINT and the taint fields require dTHR.
2888      */
2889     toptarget = NEWSV(0,0);
2890     sv_upgrade(toptarget, SVt_PVFM);
2891     sv_setpvn(toptarget, "", 0);
2892     bodytarget = NEWSV(0,0);
2893     sv_upgrade(bodytarget, SVt_PVFM);
2894     sv_setpvn(bodytarget, "", 0);
2895     formtarget = bodytarget;
2896     thr->errsv = newSVpv("", 0);
2897     (void) find_threadsv("@");  /* Ensure $@ is initialised early */
2898     return thr;
2899 }
2900 #endif /* USE_THREADS */
2901
2902 void
2903 call_list(I32 oldscope, AV *paramList)
2904 {
2905     dTHR;
2906     line_t oldline = curcop->cop_line;
2907     STRLEN len;
2908     dJMPENV;
2909     int ret;
2910
2911     while (AvFILL(paramList) >= 0) {
2912         CV *cv = (CV*)av_shift(paramList);
2913
2914         SAVEFREESV(cv);
2915
2916         JMPENV_PUSH(ret);
2917         switch (ret) {
2918         case 0: {
2919                 SV* atsv = ERRSV;
2920                 PUSHMARK(stack_sp);
2921                 perl_call_sv((SV*)cv, G_EVAL|G_DISCARD);
2922                 (void)SvPV(atsv, len);
2923                 if (len) {
2924                     JMPENV_POP;
2925                     curcop = &compiling;
2926                     curcop->cop_line = oldline;
2927                     if (paramList == beginav)
2928                         sv_catpv(atsv, "BEGIN failed--compilation aborted");
2929                     else
2930                         sv_catpv(atsv, "END failed--cleanup aborted");
2931                     while (scopestack_ix > oldscope)
2932                         LEAVE;
2933                     croak("%s", SvPVX(atsv));
2934                 }
2935             }
2936             break;
2937         case 1:
2938             STATUS_ALL_FAILURE;
2939             /* FALL THROUGH */
2940         case 2:
2941             /* my_exit() was called */
2942             while (scopestack_ix > oldscope)
2943                 LEAVE;
2944             FREETMPS;
2945             curstash = defstash;
2946             if (endav)
2947                 call_list(oldscope, endav);
2948             JMPENV_POP;
2949             curcop = &compiling;
2950             curcop->cop_line = oldline;
2951             if (statusvalue) {
2952                 if (paramList == beginav)
2953                     croak("BEGIN failed--compilation aborted");
2954                 else
2955                     croak("END failed--cleanup aborted");
2956             }
2957             my_exit_jump();
2958             /* NOTREACHED */
2959         case 3:
2960             if (!restartop) {
2961                 PerlIO_printf(PerlIO_stderr(), "panic: restartop\n");
2962                 FREETMPS;
2963                 break;
2964             }
2965             JMPENV_POP;
2966             curcop = &compiling;
2967             curcop->cop_line = oldline;
2968             JMPENV_JUMP(3);
2969         }
2970         JMPENV_POP;
2971     }
2972 }
2973
2974 void
2975 my_exit(U32 status)
2976 {
2977     dTHR;
2978
2979 #ifdef USE_THREADS
2980     DEBUG_L(PerlIO_printf(Perl_debug_log, "my_exit: thread %p, status %lu\n",
2981                           thr, (unsigned long) status));
2982 #endif /* USE_THREADS */
2983     switch (status) {
2984     case 0:
2985         STATUS_ALL_SUCCESS;
2986         break;
2987     case 1:
2988         STATUS_ALL_FAILURE;
2989         break;
2990     default:
2991         STATUS_NATIVE_SET(status);
2992         break;
2993     }
2994     my_exit_jump();
2995 }
2996
2997 void
2998 my_failure_exit(void)
2999 {
3000 #ifdef VMS
3001     if (vaxc$errno & 1) {
3002         if (STATUS_NATIVE & 1)          /* fortuitiously includes "-1" */
3003             STATUS_NATIVE_SET(44);
3004     }
3005     else {
3006         if (!vaxc$errno && errno)       /* unlikely */
3007             STATUS_NATIVE_SET(44);
3008         else
3009             STATUS_NATIVE_SET(vaxc$errno);
3010     }
3011 #else
3012     if (errno & 255)
3013         STATUS_POSIX_SET(errno);
3014     else if (STATUS_POSIX == 0)
3015         STATUS_POSIX_SET(255);
3016 #endif
3017     my_exit_jump();
3018 }
3019
3020 STATIC void
3021 my_exit_jump(void)
3022 {
3023     dTHR;
3024     register PERL_CONTEXT *cx;
3025     I32 gimme;
3026     SV **newsp;
3027
3028     if (e_tmpname) {
3029         if (e_fp) {
3030             PerlIO_close(e_fp);
3031             e_fp = Nullfp;
3032         }
3033         (void)UNLINK(e_tmpname);
3034         Safefree(e_tmpname);
3035         e_tmpname = Nullch;
3036     }
3037
3038     if (cxstack_ix >= 0) {
3039         if (cxstack_ix > 0)
3040             dounwind(0);
3041         POPBLOCK(cx,curpm);
3042         LEAVE;
3043     }
3044
3045     JMPENV_JUMP(2);
3046 }
3047
3048
3049