perl.c

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