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