perl.c

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