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
2608     sv_setpvn(get_sv("\"", TRUE), " ", 1);
2609     PL_stdingv = gv_fetchpv("STDIN",TRUE, SVt_PVIO);
2610     GvMULTI_on(PL_stdingv);
2611     IoIFP(GvIOp(PL_stdingv)) = PerlIO_stdin();
2612     tmpgv = gv_fetchpv("stdin",TRUE, SVt_PV);
2613     GvMULTI_on(tmpgv);
2614     GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(PL_stdingv));
2615
2616     tmpgv = gv_fetchpv("STDOUT",TRUE, SVt_PVIO);
2617     GvMULTI_on(tmpgv);
2618     IoOFP(GvIOp(tmpgv)) = IoIFP(GvIOp(tmpgv)) = PerlIO_stdout();
2619     setdefout(tmpgv);
2620     tmpgv = gv_fetchpv("stdout",TRUE, SVt_PV);
2621     GvMULTI_on(tmpgv);
2622     GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(PL_defoutgv));
2623
2624     othergv = gv_fetchpv("STDERR",TRUE, SVt_PVIO);
2625     GvMULTI_on(othergv);
2626     IoOFP(GvIOp(othergv)) = IoIFP(GvIOp(othergv)) = PerlIO_stderr();
2627     tmpgv = gv_fetchpv("stderr",TRUE, SVt_PV);
2628     GvMULTI_on(tmpgv);
2629     GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(othergv));
2630
2631     PL_statname = NEWSV(66,0);          /* last filename we did stat on */
2632
2633     if (!PL_osname)
2634         PL_osname = savepv(OSNAME);
2635 }
2636
2637 STATIC void
2638 S_init_postdump_symbols(pTHX_ register int argc, register char **argv, register char **env)
2639 {
2640     dTHR;
2641     char *s;
2642     SV *sv;
2643     GV* tmpgv;
2644
2645     argc--,argv++;      /* skip name of script */
2646     if (PL_doswitches) {
2647         for (; argc > 0 && **argv == '-'; argc--,argv++) {
2648             if (!argv[0][1])
2649                 break;
2650             if (argv[0][1] == '-') {
2651                 argc--,argv++;
2652                 break;
2653             }
2654             if (s = strchr(argv[0], '=')) {
2655                 *s++ = '\0';
2656                 sv_setpv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),s);
2657             }
2658             else
2659                 sv_setiv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),1);
2660         }
2661     }
2662     PL_toptarget = NEWSV(0,0);
2663     sv_upgrade(PL_toptarget, SVt_PVFM);
2664     sv_setpvn(PL_toptarget, "", 0);
2665     PL_bodytarget = NEWSV(0,0);
2666     sv_upgrade(PL_bodytarget, SVt_PVFM);
2667     sv_setpvn(PL_bodytarget, "", 0);
2668     PL_formtarget = PL_bodytarget;
2669
2670     TAINT;
2671     if (tmpgv = gv_fetchpv("0",TRUE, SVt_PV)) {
2672         sv_setpv(GvSV(tmpgv),PL_origfilename);
2673         magicname("0", "0", 1);
2674     }
2675     if (tmpgv = gv_fetchpv("\030",TRUE, SVt_PV))
2676         sv_setpv(GvSV(tmpgv),PL_origargv[0]);
2677     if (PL_argvgv = gv_fetchpv("ARGV",TRUE, SVt_PVAV)) {
2678         GvMULTI_on(PL_argvgv);
2679         (void)gv_AVadd(PL_argvgv);
2680         av_clear(GvAVn(PL_argvgv));
2681         for (; argc > 0; argc--,argv++) {
2682             av_push(GvAVn(PL_argvgv),newSVpv(argv[0],0));
2683         }
2684     }
2685     if (PL_envgv = gv_fetchpv("ENV",TRUE, SVt_PVHV)) {
2686         HV *hv;
2687         GvMULTI_on(PL_envgv);
2688         hv = GvHVn(PL_envgv);
2689         hv_magic(hv, PL_envgv, 'E');
2690 #if !defined( VMS) && !defined(EPOC)  /* VMS doesn't have environ array */
2691         /* Note that if the supplied env parameter is actually a copy
2692            of the global environ then it may now point to free'd memory
2693            if the environment has been modified since. To avoid this
2694            problem we treat env==NULL as meaning 'use the default'
2695         */
2696         if (!env)
2697             env = environ;
2698         if (env != environ)
2699             environ[0] = Nullch;
2700         for (; *env; env++) {
2701             if (!(s = strchr(*env,'=')))
2702                 continue;
2703             *s++ = '\0';
2704 #if defined(MSDOS)
2705             (void)strupr(*env);
2706 #endif
2707             sv = newSVpv(s--,0);
2708             (void)hv_store(hv, *env, s - *env, sv, 0);
2709             *s = '=';
2710 #if defined(__BORLANDC__) && defined(USE_WIN32_RTL_ENV)
2711             /* Sins of the RTL. See note in my_setenv(). */
2712             (void)PerlEnv_putenv(savepv(*env));
2713 #endif
2714         }
2715 #endif
2716 #ifdef DYNAMIC_ENV_FETCH
2717         HvNAME(hv) = savepv(ENV_HV_NAME);
2718 #endif
2719     }
2720     TAINT_NOT;
2721     if (tmpgv = gv_fetchpv("$",TRUE, SVt_PV))
2722         sv_setiv(GvSV(tmpgv), (IV)getpid());
2723 }
2724
2725 STATIC void
2726 S_init_perllib(pTHX)
2727 {
2728     char *s;
2729     if (!PL_tainting) {
2730 #ifndef VMS
2731         s = PerlEnv_getenv("PERL5LIB");
2732         if (s)
2733             incpush(s, TRUE);
2734         else
2735             incpush(PerlEnv_getenv("PERLLIB"), FALSE);
2736 #else /* VMS */
2737         /* Treat PERL5?LIB as a possible search list logical name -- the
2738          * "natural" VMS idiom for a Unix path string.  We allow each
2739          * element to be a set of |-separated directories for compatibility.
2740          */
2741         char buf[256];
2742         int idx = 0;
2743         if (my_trnlnm("PERL5LIB",buf,0))
2744             do { incpush(buf,TRUE); } while (my_trnlnm("PERL5LIB",buf,++idx));
2745         else
2746             while (my_trnlnm("PERLLIB",buf,idx++)) incpush(buf,FALSE);
2747 #endif /* VMS */
2748     }
2749
2750 /* Use the ~-expanded versions of APPLLIB (undocumented),
2751     ARCHLIB PRIVLIB SITEARCH and SITELIB
2752 */
2753 #ifdef APPLLIB_EXP
2754     incpush(APPLLIB_EXP, TRUE);
2755 #endif
2756
2757 #ifdef ARCHLIB_EXP
2758     incpush(ARCHLIB_EXP, FALSE);
2759 #endif
2760 #ifndef PRIVLIB_EXP
2761 #define PRIVLIB_EXP "/usr/local/lib/perl5:/usr/local/lib/perl"
2762 #endif
2763 #if defined(WIN32)
2764     incpush(PRIVLIB_EXP, TRUE);
2765 #else
2766     incpush(PRIVLIB_EXP, FALSE);
2767 #endif
2768
2769 #ifdef SITEARCH_EXP
2770     incpush(SITEARCH_EXP, FALSE);
2771 #endif
2772 #ifdef SITELIB_EXP
2773 #if defined(WIN32)
2774     incpush(SITELIB_EXP, TRUE);
2775 #else
2776     incpush(SITELIB_EXP, FALSE);
2777 #endif
2778 #endif
2779     if (!PL_tainting)
2780         incpush(".", FALSE);
2781 }
2782
2783 #if defined(DOSISH)
2784 #    define PERLLIB_SEP ';'
2785 #else
2786 #  if defined(VMS)
2787 #    define PERLLIB_SEP '|'
2788 #  else
2789 #    define PERLLIB_SEP ':'
2790 #  endif
2791 #endif
2792 #ifndef PERLLIB_MANGLE
2793 #  define PERLLIB_MANGLE(s,n) (s)
2794 #endif
2795
2796 STATIC void
2797 S_incpush(pTHX_ char *p, int addsubdirs)
2798 {
2799     SV *subdir = Nullsv;
2800
2801     if (!p)
2802         return;
2803
2804     if (addsubdirs) {
2805         subdir = sv_newmortal();
2806         if (!PL_archpat_auto) {
2807             STRLEN len = (sizeof(ARCHNAME) + strlen(PL_patchlevel)
2808                           + sizeof("//auto"));
2809             New(55, PL_archpat_auto, len, char);
2810             sprintf(PL_archpat_auto, "/%s/%s/auto", ARCHNAME, PL_patchlevel);
2811 #ifdef VMS
2812         for (len = sizeof(ARCHNAME) + 2;
2813              PL_archpat_auto[len] != '\0' && PL_archpat_auto[len] != '/'; len++)
2814                 if (PL_archpat_auto[len] == '.') PL_archpat_auto[len] = '_';
2815 #endif
2816         }
2817     }
2818
2819     /* Break at all separators */
2820     while (p && *p) {
2821         SV *libdir = NEWSV(55,0);
2822         char *s;
2823
2824         /* skip any consecutive separators */
2825         while ( *p == PERLLIB_SEP ) {
2826             /* Uncomment the next line for PATH semantics */
2827             /* av_push(GvAVn(PL_incgv), newSVpvn(".", 1)); */
2828             p++;
2829         }
2830
2831         if ( (s = strchr(p, PERLLIB_SEP)) != Nullch ) {
2832             sv_setpvn(libdir, PERLLIB_MANGLE(p, (STRLEN)(s - p)),
2833                       (STRLEN)(s - p));
2834             p = s + 1;
2835         }
2836         else {
2837             sv_setpv(libdir, PERLLIB_MANGLE(p, 0));
2838             p = Nullch; /* break out */
2839         }
2840
2841         /*
2842          * BEFORE pushing libdir onto @INC we may first push version- and
2843          * archname-specific sub-directories.
2844          */
2845         if (addsubdirs) {
2846             struct stat tmpstatbuf;
2847 #ifdef VMS
2848             char *unix;
2849             STRLEN len;
2850
2851             if ((unix = tounixspec_ts(SvPV(libdir,len),Nullch)) != Nullch) {
2852                 len = strlen(unix);
2853                 while (unix[len-1] == '/') len--;  /* Cosmetic */
2854                 sv_usepvn(libdir,unix,len);
2855             }
2856             else
2857                 PerlIO_printf(PerlIO_stderr(),
2858                               "Failed to unixify @INC element \"%s\"\n",
2859                               SvPV(libdir,len));
2860 #endif
2861             /* .../archname/version if -d .../archname/version/auto */
2862             sv_setsv(subdir, libdir);
2863             sv_catpv(subdir, PL_archpat_auto);
2864             if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
2865                   S_ISDIR(tmpstatbuf.st_mode))
2866                 av_push(GvAVn(PL_incgv),
2867                         newSVpvn(SvPVX(subdir), SvCUR(subdir) - sizeof "auto"));
2868
2869             /* .../archname if -d .../archname/auto */
2870             sv_insert(subdir, SvCUR(libdir) + sizeof(ARCHNAME),
2871                       strlen(PL_patchlevel) + 1, "", 0);
2872             if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
2873                   S_ISDIR(tmpstatbuf.st_mode))
2874                 av_push(GvAVn(PL_incgv),
2875                         newSVpvn(SvPVX(subdir), SvCUR(subdir) - sizeof "auto"));
2876         }
2877
2878         /* finally push this lib directory on the end of @INC */
2879         av_push(GvAVn(PL_incgv), libdir);
2880     }
2881 }
2882
2883 #ifdef USE_THREADS
2884 STATIC struct perl_thread *
2885 S_init_main_thread(pTHX)
2886 {
2887 #ifndef PERL_IMPLICIT_CONTEXT
2888     struct perl_thread *thr;
2889 #endif
2890     XPV *xpv;
2891
2892     Newz(53, thr, 1, struct perl_thread);
2893     PL_curcop = &PL_compiling;
2894     thr->cvcache = newHV();
2895     thr->threadsv = newAV();
2896     /* thr->threadsvp is set when find_threadsv is called */
2897     thr->specific = newAV();
2898     thr->errhv = newHV();
2899     thr->flags = THRf_R_JOINABLE;
2900     MUTEX_INIT(&thr->mutex);
2901     /* Handcraft thrsv similarly to mess_sv */
2902     New(53, PL_thrsv, 1, SV);
2903     Newz(53, xpv, 1, XPV);
2904     SvFLAGS(PL_thrsv) = SVt_PV;
2905     SvANY(PL_thrsv) = (void*)xpv;
2906     SvREFCNT(PL_thrsv) = 1 << 30;       /* practically infinite */
2907     SvPVX(PL_thrsv) = (char*)thr;
2908     SvCUR_set(PL_thrsv, sizeof(thr));
2909     SvLEN_set(PL_thrsv, sizeof(thr));
2910     *SvEND(PL_thrsv) = '\0';    /* in the trailing_nul field */
2911     thr->oursv = PL_thrsv;
2912     PL_chopset = " \n-";
2913     PL_dumpindent = 4;
2914
2915     MUTEX_LOCK(&PL_threads_mutex);
2916     PL_nthreads++;
2917     thr->tid = 0;
2918     thr->next = thr;
2919     thr->prev = thr;
2920     MUTEX_UNLOCK(&PL_threads_mutex);
2921
2922 #ifdef HAVE_THREAD_INTERN
2923     Perl_init_thread_intern(thr);
2924 #endif
2925
2926 #ifdef SET_THREAD_SELF
2927     SET_THREAD_SELF(thr);
2928 #else
2929     thr->self = pthread_self();
2930 #endif /* SET_THREAD_SELF */
2931     SET_THR(thr);
2932
2933     /*
2934      * These must come after the SET_THR because sv_setpvn does
2935      * SvTAINT and the taint fields require dTHR.
2936      */
2937     PL_toptarget = NEWSV(0,0);
2938     sv_upgrade(PL_toptarget, SVt_PVFM);
2939     sv_setpvn(PL_toptarget, "", 0);
2940     PL_bodytarget = NEWSV(0,0);
2941     sv_upgrade(PL_bodytarget, SVt_PVFM);
2942     sv_setpvn(PL_bodytarget, "", 0);
2943     PL_formtarget = PL_bodytarget;
2944     thr->errsv = newSVpvn("", 0);
2945     (void) find_threadsv("@");  /* Ensure $@ is initialised early */
2946
2947     PL_maxscream = -1;
2948     PL_regcompp = FUNC_NAME_TO_PTR(Perl_pregcomp);
2949     PL_regexecp = FUNC_NAME_TO_PTR(Perl_regexec_flags);
2950     PL_regindent = 0;
2951     PL_reginterp_cnt = 0;
2952
2953     return thr;
2954 }
2955 #endif /* USE_THREADS */
2956
2957 void
2958 Perl_call_list(pTHX_ I32 oldscope, AV *paramList)
2959 {
2960     dTHR;
2961     SV *atsv = ERRSV;
2962     line_t oldline = PL_curcop->cop_line;
2963     CV *cv;
2964     STRLEN len;
2965     int ret;
2966
2967     while (AvFILL(paramList) >= 0) {
2968         cv = (CV*)av_shift(paramList);
2969         SAVEFREESV(cv);
2970         CALLPROTECT(aTHX_ &ret, FUNC_NAME_TO_PTR(S_call_list_body), cv);
2971         switch (ret) {
2972         case 0:
2973             (void)SvPV(atsv, len);
2974             if (len) {
2975                 PL_curcop = &PL_compiling;
2976                 PL_curcop->cop_line = oldline;
2977                 if (paramList == PL_beginav)
2978                     sv_catpv(atsv, "BEGIN failed--compilation aborted");
2979                 else
2980                     sv_catpv(atsv, "END failed--cleanup aborted");
2981                 while (PL_scopestack_ix > oldscope)
2982                     LEAVE;
2983                 Perl_croak(aTHX_ "%s", SvPVX(atsv));
2984             }
2985             break;
2986         case 1:
2987             STATUS_ALL_FAILURE;
2988             /* FALL THROUGH */
2989         case 2:
2990             /* my_exit() was called */
2991             while (PL_scopestack_ix > oldscope)
2992                 LEAVE;
2993             FREETMPS;
2994             PL_curstash = PL_defstash;
2995             if (PL_endav)
2996                 call_list(oldscope, PL_endav);
2997             PL_curcop = &PL_compiling;
2998             PL_curcop->cop_line = oldline;
2999             if (PL_statusvalue) {
3000                 if (paramList == PL_beginav)
3001                     Perl_croak(aTHX_ "BEGIN failed--compilation aborted");
3002                 else
3003                     Perl_croak(aTHX_ "END failed--cleanup aborted");
3004             }
3005             my_exit_jump();
3006             /* NOTREACHED */
3007         case 3:
3008             if (PL_restartop) {
3009                 PL_curcop = &PL_compiling;
3010                 PL_curcop->cop_line = oldline;
3011                 JMPENV_JUMP(3);
3012             }
3013             PerlIO_printf(PerlIO_stderr(), "panic: restartop\n");
3014             FREETMPS;
3015             break;
3016         }
3017     }
3018 }
3019
3020 STATIC void *
3021 S_call_list_body(pTHX_ va_list args)
3022 {
3023     dTHR;
3024     CV *cv = va_arg(args, CV*);
3025
3026     PUSHMARK(PL_stack_sp);
3027     call_sv((SV*)cv, G_EVAL|G_DISCARD);
3028     return NULL;
3029 }
3030
3031 void
3032 Perl_my_exit(pTHX_ U32 status)
3033 {
3034     dTHR;
3035
3036     DEBUG_S(PerlIO_printf(Perl_debug_log, "my_exit: thread %p, status %lu\n",
3037                           thr, (unsigned long) status));
3038     switch (status) {
3039     case 0:
3040         STATUS_ALL_SUCCESS;
3041         break;
3042     case 1:
3043         STATUS_ALL_FAILURE;
3044         break;
3045     default:
3046         STATUS_NATIVE_SET(status);
3047         break;
3048     }
3049     my_exit_jump();
3050 }
3051
3052 void
3053 Perl_my_failure_exit(pTHX)
3054 {
3055 #ifdef VMS
3056     if (vaxc$errno & 1) {
3057         if (STATUS_NATIVE & 1)          /* fortuitiously includes "-1" */
3058             STATUS_NATIVE_SET(44);
3059     }
3060     else {
3061         if (!vaxc$errno && errno)       /* unlikely */
3062             STATUS_NATIVE_SET(44);
3063         else
3064             STATUS_NATIVE_SET(vaxc$errno);
3065     }
3066 #else
3067     int exitstatus;
3068     if (errno & 255)
3069         STATUS_POSIX_SET(errno);
3070     else {
3071         exitstatus = STATUS_POSIX >> 8;
3072         if (exitstatus & 255)
3073             STATUS_POSIX_SET(exitstatus);
3074         else
3075             STATUS_POSIX_SET(255);
3076     }
3077 #endif
3078     my_exit_jump();
3079 }
3080
3081 STATIC void
3082 S_my_exit_jump(pTHX)
3083 {
3084     dTHR;
3085     register PERL_CONTEXT *cx;
3086     I32 gimme;
3087     SV **newsp;
3088
3089     if (PL_e_script) {
3090         SvREFCNT_dec(PL_e_script);
3091         PL_e_script = Nullsv;
3092     }
3093
3094     POPSTACK_TO(PL_mainstack);
3095     if (cxstack_ix >= 0) {
3096         if (cxstack_ix > 0)
3097             dounwind(0);
3098         POPBLOCK(cx,PL_curpm);
3099         LEAVE;
3100     }
3101
3102     JMPENV_JUMP(2);
3103 }
3104
3105 #ifdef PERL_OBJECT
3106 #define NO_XSLOCKS
3107 #endif  /* PERL_OBJECT */
3108
3109 #include "XSUB.h"
3110
3111 static I32
3112 read_e_script(pTHXo_ int idx, SV *buf_sv, int maxlen)
3113 {
3114     char *p, *nl;
3115     p  = SvPVX(PL_e_script);
3116     nl = strchr(p, '\n');
3117     nl = (nl) ? nl+1 : SvEND(PL_e_script);
3118     if (nl-p == 0) {
3119         filter_del(read_e_script);
3120         return 0;
3121     }
3122     sv_catpvn(buf_sv, p, nl-p);
3123     sv_chop(PL_e_script, nl);
3124     return 1;
3125 }
3126
3127