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 = NULL;
  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(Perl_debug_log,
 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(Perl_debug_log,
 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(Perl_debug_log,
 246                                   "perl_destruct: joined zombie %p OK\n", t));
 247             goto retry_cleanup;
 248         case THRf_R_JOINABLE:
 249             DEBUG_S(PerlIO_printf(Perl_debug_log,
 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(Perl_debug_log,
 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(Perl_debug_log,
 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(Perl_debug_log, "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
 332     /* call exit list functions */
 333     while (PL_exitlistlen-- > 0)
 334         PL_exitlist[PL_exitlistlen].fn(aTHXo_ PL_exitlist[PL_exitlistlen].ptr);
 335
 336     Safefree(PL_exitlist);
 337
 338     if (destruct_level == 0){
 339
 340         DEBUG_P(debprofdump());
 341
 342         /* The exit() function will do everything that needs doing. */
 343         return;
 344     }
 345
 346     /* loosen bonds of global variables */
 347
 348     if(PL_rsfp) {
 349         (void)PerlIO_close(PL_rsfp);
 350         PL_rsfp = Nullfp;
 351     }
 352
 353     /* Filters for program text */
 354     SvREFCNT_dec(PL_rsfp_filters);
 355     PL_rsfp_filters = Nullav;
 356
 357     /* switches */
 358     PL_preprocess   = FALSE;
 359     PL_minus_n      = FALSE;
 360     PL_minus_p      = FALSE;
 361     PL_minus_l      = FALSE;
 362     PL_minus_a      = FALSE;
 363     PL_minus_F      = FALSE;
 364     PL_doswitches   = FALSE;
 365     PL_dowarn       = G_WARN_OFF;
 366     PL_doextract    = FALSE;
 367     PL_sawampersand = FALSE;    /* must save all match strings */
 368     PL_sawstudy     = FALSE;    /* do fbm_instr on all strings */
 369     PL_sawvec       = FALSE;
 370     PL_unsafe       = FALSE;
 371
 372     Safefree(PL_inplace);
 373     PL_inplace = Nullch;
 374
 375     if (PL_e_script) {
 376         SvREFCNT_dec(PL_e_script);
 377         PL_e_script = Nullsv;
 378     }
 379
 380     /* magical thingies */
 381
 382     Safefree(PL_ofs);   /* $, */
 383     PL_ofs = Nullch;
 384
 385     Safefree(PL_ors);   /* $\ */
 386     PL_ors = Nullch;
 387
 388     SvREFCNT_dec(PL_rs);        /* $/ */
 389     PL_rs = Nullsv;
 390
 391     SvREFCNT_dec(PL_nrs);       /* $/ helper */
 392     PL_nrs = Nullsv;
 393
 394     PL_multiline = 0;   /* $* */
 395
 396     SvREFCNT_dec(PL_statname);
 397     PL_statname = Nullsv;
 398     PL_statgv = Nullgv;
 399
 400     /* defgv, aka *_ should be taken care of elsewhere */
 401
 402     /* clean up after study() */
 403     SvREFCNT_dec(PL_lastscream);
 404     PL_lastscream = Nullsv;
 405     Safefree(PL_screamfirst);
 406     PL_screamfirst = 0;
 407     Safefree(PL_screamnext);
 408     PL_screamnext  = 0;
 409
 410     /* float buffer */
 411     Safefree(PL_efloatbuf);
 412     PL_efloatbuf = Nullch;
 413     PL_efloatsize = 0;
 414
 415     /* startup and shutdown function lists */
 416     SvREFCNT_dec(PL_beginav);
 417     SvREFCNT_dec(PL_endav);
 418     SvREFCNT_dec(PL_initav);
 419     PL_beginav = Nullav;
 420     PL_endav = Nullav;
 421     PL_initav = Nullav;
 422
 423     /* shortcuts just get cleared */
 424     PL_envgv = Nullgv;
 425     PL_siggv = Nullgv;
 426     PL_incgv = Nullgv;
 427     PL_hintgv = Nullgv;
 428     PL_errgv = Nullgv;
 429     PL_argvgv = Nullgv;
 430     PL_argvoutgv = Nullgv;
 431     PL_stdingv = Nullgv;
 432     PL_stderrgv = Nullgv;
 433     PL_last_in_gv = Nullgv;
 434     PL_replgv = Nullgv;
 435
 436     /* reset so print() ends up where we expect */
 437     setdefout(Nullgv);
 438
 439     /* Prepare to destruct main symbol table.  */
 440
 441     hv = PL_defstash;
 442     PL_defstash = 0;
 443     SvREFCNT_dec(hv);
 444
 445     /* clear queued errors */
 446     SvREFCNT_dec(PL_errors);
 447     PL_errors = Nullsv;
 448
 449     FREETMPS;
 450     if (destruct_level >= 2 && ckWARN_d(WARN_INTERNAL)) {
 451         if (PL_scopestack_ix != 0)
 452             Perl_warner(aTHX_ WARN_INTERNAL,
 453                  "Unbalanced scopes: %ld more ENTERs than LEAVEs\n",
 454                  (long)PL_scopestack_ix);
 455         if (PL_savestack_ix != 0)
 456             Perl_warner(aTHX_ WARN_INTERNAL,
 457                  "Unbalanced saves: %ld more saves than restores\n",
 458                  (long)PL_savestack_ix);
 459         if (PL_tmps_floor != -1)
 460             Perl_warner(aTHX_ WARN_INTERNAL,"Unbalanced tmps: %ld more allocs than frees\n",
 461                  (long)PL_tmps_floor + 1);
 462         if (cxstack_ix != -1)
 463             Perl_warner(aTHX_ WARN_INTERNAL,"Unbalanced context: %ld more PUSHes than POPs\n",
 464                  (long)cxstack_ix + 1);
 465     }
 466
 467     /* Now absolutely destruct everything, somehow or other, loops or no. */
 468     last_sv_count = 0;
 469     SvFLAGS(PL_strtab) |= SVTYPEMASK;           /* don't clean out strtab now */
 470     while (PL_sv_count != 0 && PL_sv_count != last_sv_count) {
 471         last_sv_count = PL_sv_count;
 472         sv_clean_all();
 473     }
 474     SvFLAGS(PL_strtab) &= ~SVTYPEMASK;
 475     SvFLAGS(PL_strtab) |= SVt_PVHV;
 476
 477     /* Destruct the global string table. */
 478     {
 479         /* Yell and reset the HeVAL() slots that are still holding refcounts,
 480          * so that sv_free() won't fail on them.
 481          */
 482         I32 riter;
 483         I32 max;
 484         HE *hent;
 485         HE **array;
 486
 487         riter = 0;
 488         max = HvMAX(PL_strtab);
 489         array = HvARRAY(PL_strtab);
 490         hent = array[0];
 491         for (;;) {
 492             if (hent && ckWARN_d(WARN_INTERNAL)) {
 493                 Perl_warner(aTHX_ WARN_INTERNAL,
 494                      "Unbalanced string table refcount: (%d) for \"%s\"",
 495                      HeVAL(hent) - Nullsv, HeKEY(hent));
 496                 HeVAL(hent) = Nullsv;
 497                 hent = HeNEXT(hent);
 498             }
 499             if (!hent) {
 500                 if (++riter > max)
 501                     break;
 502                 hent = array[riter];
 503             }
 504         }
 505     }
 506     SvREFCNT_dec(PL_strtab);
 507
 508     if (PL_sv_count != 0 && ckWARN_d(WARN_INTERNAL))
 509         Perl_warner(aTHX_ WARN_INTERNAL,"Scalars leaked: %ld\n", (long)PL_sv_count);
 510
 511     sv_free_arenas();
 512
 513     /* No SVs have survived, need to clean out */
 514     PL_linestr = NULL;
 515     PL_pidstatus = Nullhv;
 516     Safefree(PL_origfilename);
 517     Safefree(PL_archpat_auto);
 518     Safefree(PL_reg_start_tmp);
 519     if (PL_reg_curpm)
 520         Safefree(PL_reg_curpm);
 521     Safefree(PL_reg_poscache);
 522     Safefree(HeKEY_hek(&PL_hv_fetch_ent_mh));
 523     Safefree(PL_op_mask);
 524     nuke_stacks();
 525     PL_hints = 0;               /* Reset hints. Should hints be per-interpreter ? */
 526
 527     DEBUG_P(debprofdump());
 528 #ifdef USE_THREADS
 529     MUTEX_DESTROY(&PL_strtab_mutex);
 530     MUTEX_DESTROY(&PL_sv_mutex);
 531     MUTEX_DESTROY(&PL_eval_mutex);
 532     MUTEX_DESTROY(&PL_cred_mutex);
 533     COND_DESTROY(&PL_eval_cond);
 534 #ifdef EMULATE_ATOMIC_REFCOUNTS
 535     MUTEX_DESTROY(&PL_svref_mutex);
 536 #endif /* EMULATE_ATOMIC_REFCOUNTS */
 537
 538     /* As the penultimate thing, free the non-arena SV for thrsv */
 539     Safefree(SvPVX(PL_thrsv));
 540     Safefree(SvANY(PL_thrsv));
 541     Safefree(PL_thrsv);
 542     PL_thrsv = Nullsv;
 543 #endif /* USE_THREADS */
 544
 545     /* As the absolutely last thing, free the non-arena SV for mess() */
 546
 547     if (PL_mess_sv) {
 548         /* it could have accumulated taint magic */
 549         if (SvTYPE(PL_mess_sv) >= SVt_PVMG) {
 550             MAGIC* mg;
 551             MAGIC* moremagic;
 552             for (mg = SvMAGIC(PL_mess_sv); mg; mg = moremagic) {
 553                 moremagic = mg->mg_moremagic;
 554                 if (mg->mg_ptr && mg->mg_type != 'g' && mg->mg_len >= 0)
 555                     Safefree(mg->mg_ptr);
 556                 Safefree(mg);
 557             }
 558         }
 559         /* we know that type >= SVt_PV */
 560         SvOOK_off(PL_mess_sv);
 561         Safefree(SvPVX(PL_mess_sv));
 562         Safefree(SvANY(PL_mess_sv));
 563         Safefree(PL_mess_sv);
 564         PL_mess_sv = Nullsv;
 565     }
 566 }
 567
 568 void
 569 perl_free(pTHXx)
 570 {
 571 #if defined(PERL_OBJECT)
 572     PerlMem_free(this);
 573 #else
 574     PerlMem_free(aTHXx);
 575 #endif
 576 }
 577
 578 void
 579 Perl_call_atexit(pTHX_ ATEXIT_t fn, void *ptr)
 580 {
 581     Renew(PL_exitlist, PL_exitlistlen+1, PerlExitListEntry);
 582     PL_exitlist[PL_exitlistlen].fn = fn;
 583     PL_exitlist[PL_exitlistlen].ptr = ptr;
 584     ++PL_exitlistlen;
 585 }
 586
 587 int
 588 perl_parse(pTHXx_ XSINIT_t xsinit, int argc, char **argv, char **env)
 589 {
 590     dTHR;
 591     I32 oldscope;
 592     int ret;
 593     dJMPENV;
 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_ pcur_env, &ret, MEMBER_TO_FPTR(S_parse_body),
 643                 env, xsinit);
 644     switch (ret) {
 645     case 0:
 646         return 0;
 647     case 1:
 648         STATUS_ALL_FAILURE;
 649         /* FALL THROUGH */
 650     case 2:
 651         /* my_exit() was called */
 652         while (PL_scopestack_ix > oldscope)
 653             LEAVE;
 654         FREETMPS;
 655         PL_curstash = PL_defstash;
 656         if (PL_endav && !PL_minus_c)
 657             call_list(oldscope, PL_endav);
 658         return STATUS_NATIVE_EXPORT;
 659     case 3:
 660         PerlIO_printf(Perl_error_log, "panic: top_env\n");
 661         return 1;
 662     }
 663     return 0;
 664 }
 665
 666 STATIC void *
 667 S_parse_body(pTHX_ va_list args)
 668 {
 669     dTHR;
 670     int argc = PL_origargc;
 671     char **argv = PL_origargv;
 672     char **env = va_arg(args, char**);
 673     char *scriptname = NULL;
 674     int fdscript = -1;
 675     VOL bool dosearch = FALSE;
 676     char *validarg = "";
 677     AV* comppadlist;
 678     register SV *sv;
 679     register char *s;
 680
 681     XSINIT_t xsinit = va_arg(args, XSINIT_t);
 682
 683     sv_setpvn(PL_linestr,"",0);
 684     sv = newSVpvn("",0);                /* first used for -I flags */
 685     SAVEFREESV(sv);
 686     init_main_stash();
 687
 688     for (argc--,argv++; argc > 0; argc--,argv++) {
 689         if (argv[0][0] != '-' || !argv[0][1])
 690             break;
 691 #ifdef DOSUID
 692     if (*validarg)
 693         validarg = " PHOOEY ";
 694     else
 695         validarg = argv[0];
 696 #endif
 697         s = argv[0]+1;
 698       reswitch:
 699         switch (*s) {
 700 #ifndef PERL_STRICT_CR
 701         case '\r':
 702 #endif
 703         case ' ':
 704         case '0':
 705         case 'F':
 706         case 'a':
 707         case 'c':
 708         case 'd':
 709         case 'D':
 710         case 'h':
 711         case 'i':
 712         case 'l':
 713         case 'M':
 714         case 'm':
 715         case 'n':
 716         case 'p':
 717         case 's':
 718         case 'u':
 719         case 'U':
 720         case 'v':
 721         case 'W':
 722         case 'X':
 723         case 'w':
 724             if (s = moreswitches(s))
 725                 goto reswitch;
 726             break;
 727
 728         case 'T':
 729             PL_tainting = TRUE;
 730             s++;
 731             goto reswitch;
 732
 733         case 'e':
 734             if (PL_euid != PL_uid || PL_egid != PL_gid)
 735                 Perl_croak(aTHX_ "No -e allowed in setuid scripts");
 736             if (!PL_e_script) {
 737                 PL_e_script = newSVpvn("",0);
 738                 filter_add(read_e_script, NULL);
 739             }
 740             if (*++s)
 741                 sv_catpv(PL_e_script, s);
 742             else if (argv[1]) {
 743                 sv_catpv(PL_e_script, argv[1]);
 744                 argc--,argv++;
 745             }
 746             else
 747                 Perl_croak(aTHX_ "No code specified for -e");
 748             sv_catpv(PL_e_script, "\n");
 749             break;
 750
 751         case 'I':       /* -I handled both here and in moreswitches() */
 752             forbid_setid("-I");
 753             if (!*++s && (s=argv[1]) != Nullch) {
 754                 argc--,argv++;
 755             }
 756             while (s && isSPACE(*s))
 757                 ++s;
 758             if (s && *s) {
 759                 char *e, *p;
 760                 for (e = s; *e && !isSPACE(*e); e++) ;
 761                 p = savepvn(s, e-s);
 762                 incpush(p, TRUE);
 763                 sv_catpv(sv,"-I");
 764                 sv_catpv(sv,p);
 765                 sv_catpv(sv," ");
 766                 Safefree(p);
 767             }   /* XXX else croak? */
 768             break;
 769         case 'P':
 770             forbid_setid("-P");
 771             PL_preprocess = TRUE;
 772             s++;
 773             goto reswitch;
 774         case 'S':
 775             forbid_setid("-S");
 776             dosearch = TRUE;
 777             s++;
 778             goto reswitch;
 779         case 'V':
 780             if (!PL_preambleav)
 781                 PL_preambleav = newAV();
 782             av_push(PL_preambleav, newSVpv("use Config qw(myconfig config_vars)",0));
 783             if (*++s != ':')  {
 784                 PL_Sv = newSVpv("print myconfig();",0);
 785 #ifdef VMS
 786                 sv_catpv(PL_Sv,"print \"\\nCharacteristics of this PERLSHR image: \\n\",");
 787 #else
 788                 sv_catpv(PL_Sv,"print \"\\nCharacteristics of this binary (from libperl): \\n\",");
 789 #endif
 790 #if defined(DEBUGGING) || defined(MULTIPLICITY)
 791                 sv_catpv(PL_Sv,"\"  Compile-time options:");
 792 #  ifdef DEBUGGING
 793                 sv_catpv(PL_Sv," DEBUGGING");
 794 #  endif
 795 #  ifdef MULTIPLICITY
 796                 sv_catpv(PL_Sv," MULTIPLICITY");
 797 #  endif
 798                 sv_catpv(PL_Sv,"\\n\",");
 799 #endif
 800 #if defined(LOCAL_PATCH_COUNT)
 801                 if (LOCAL_PATCH_COUNT > 0) {
 802                     int i;
 803                     sv_catpv(PL_Sv,"\"  Locally applied patches:\\n\",");
 804                     for (i = 1; i <= LOCAL_PATCH_COUNT; i++) {
 805                         if (PL_localpatches[i])
 806                             Perl_sv_catpvf(aTHX_ PL_Sv,"q\"  \t%s\n\",",PL_localpatches[i]);
 807                     }
 808                 }
 809 #endif
 810                 Perl_sv_catpvf(aTHX_ PL_Sv,"\"  Built under %s\\n\"",OSNAME);
 811 #ifdef __DATE__
 812 #  ifdef __TIME__
 813                 Perl_sv_catpvf(aTHX_ PL_Sv,",\"  Compiled at %s %s\\n\"",__DATE__,__TIME__);
 814 #  else
 815                 Perl_sv_catpvf(aTHX_ PL_Sv,",\"  Compiled on %s\\n\"",__DATE__);
 816 #  endif
 817 #endif
 818                 sv_catpv(PL_Sv, "; \
 819 $\"=\"\\n    \"; \
 820 @env = map { \"$_=\\\"$ENV{$_}\\\"\" } sort grep {/^PERL/} keys %ENV; \
 821 print \"  \\%ENV:\\n    @env\\n\" if @env; \
 822 print \"  \\@INC:\\n    @INC\\n\";");
 823             }
 824             else {
 825                 PL_Sv = newSVpv("config_vars(qw(",0);
 826                 sv_catpv(PL_Sv, ++s);
 827                 sv_catpv(PL_Sv, "))");
 828                 s += strlen(s);
 829             }
 830             av_push(PL_preambleav, PL_Sv);
 831             scriptname = BIT_BUCKET;    /* don't look for script or read stdin */
 832             goto reswitch;
 833         case 'x':
 834             PL_doextract = TRUE;
 835             s++;
 836             if (*s)
 837                 PL_cddir = savepv(s);
 838             break;
 839         case 0:
 840             break;
 841         case '-':
 842             if (!*++s || isSPACE(*s)) {
 843                 argc--,argv++;
 844                 goto switch_end;
 845             }
 846             /* catch use of gnu style long options */
 847             if (strEQ(s, "version")) {
 848                 s = "v";
 849                 goto reswitch;
 850             }
 851             if (strEQ(s, "help")) {
 852                 s = "h";
 853                 goto reswitch;
 854             }
 855             s--;
 856             /* FALL THROUGH */
 857         default:
 858             Perl_croak(aTHX_ "Unrecognized switch: -%s  (-h will show valid options)",s);
 859         }
 860     }
 861   switch_end:
 862
 863     if (
 864 #ifndef SECURE_INTERNAL_GETENV
 865         !PL_tainting &&
 866 #endif
 867                         (s = PerlEnv_getenv("PERL5OPT"))) {
 868         while (isSPACE(*s))
 869             s++;
 870         if (*s == '-' && *(s+1) == 'T')
 871             PL_tainting = TRUE;
 872         else {
 873             while (s && *s) {
 874                 while (isSPACE(*s))
 875                     s++;
 876                 if (*s == '-') {
 877                     s++;
 878                     if (isSPACE(*s))
 879                         continue;
 880                 }
 881                 if (!*s)
 882                     break;
 883                 if (!strchr("DIMUdmw", *s))
 884                     Perl_croak(aTHX_ "Illegal switch in PERL5OPT: -%c", *s);
 885                 s = moreswitches(s);
 886             }
 887         }
 888     }
 889
 890     if (!scriptname)
 891         scriptname = argv[0];
 892     if (PL_e_script) {
 893         argc++,argv--;
 894         scriptname = BIT_BUCKET;        /* don't look for script or read stdin */
 895     }
 896     else if (scriptname == Nullch) {
 897 #ifdef MSDOS
 898         if ( PerlLIO_isatty(PerlIO_fileno(PerlIO_stdin())) )
 899             moreswitches("h");
 900 #endif
 901         scriptname = "-";
 902     }
 903
 904     init_perllib();
 905
 906     open_script(scriptname,dosearch,sv,&fdscript);
 907
 908     validate_suid(validarg, scriptname,fdscript);
 909
 910     if (PL_doextract)
 911         find_beginning();
 912
 913     PL_main_cv = PL_compcv = (CV*)NEWSV(1104,0);
 914     sv_upgrade((SV *)PL_compcv, SVt_PVCV);
 915     CvUNIQUE_on(PL_compcv);
 916
 917     PL_comppad = newAV();
 918     av_push(PL_comppad, Nullsv);
 919     PL_curpad = AvARRAY(PL_comppad);
 920     PL_comppad_name = newAV();
 921     PL_comppad_name_fill = 0;
 922     PL_min_intro_pending = 0;
 923     PL_padix = 0;
 924 #ifdef USE_THREADS
 925     av_store(PL_comppad_name, 0, newSVpvn("@_", 2));
 926     PL_curpad[0] = (SV*)newAV();
 927     SvPADMY_on(PL_curpad[0]);   /* XXX Needed? */
 928     CvOWNER(PL_compcv) = 0;
 929     New(666, CvMUTEXP(PL_compcv), 1, perl_mutex);
 930     MUTEX_INIT(CvMUTEXP(PL_compcv));
 931 #endif /* USE_THREADS */
 932
 933     comppadlist = newAV();
 934     AvREAL_off(comppadlist);
 935     av_store(comppadlist, 0, (SV*)PL_comppad_name);
 936     av_store(comppadlist, 1, (SV*)PL_comppad);
 937     CvPADLIST(PL_compcv) = comppadlist;
 938
 939     boot_core_UNIVERSAL();
 940     boot_core_xsutils();
 941
 942     if (xsinit)
 943         (*xsinit)(aTHXo);       /* in case linked C routines want magical variables */
 944 #if defined(VMS) || defined(WIN32) || defined(DJGPP)
 945     init_os_extras();
 946 #endif
 947
 948 #ifdef USE_SOCKS
 949     SOCKSinit(argv[0]);
 950 #endif
 951
 952     init_predump_symbols();
 953     /* init_postdump_symbols not currently designed to be called */
 954     /* more than once (ENV isn't cleared first, for example)     */
 955     /* But running with -u leaves %ENV & @ARGV undefined!    XXX */
 956     if (!PL_do_undump)
 957         init_postdump_symbols(argc,argv,env);
 958
 959     init_lexer();
 960
 961     /* now parse the script */
 962
 963     SETERRNO(0,SS$_NORMAL);
 964     PL_error_count = 0;
 965     if (yyparse() || PL_error_count) {
 966         if (PL_minus_c)
 967             Perl_croak(aTHX_ "%s had compilation errors.\n", PL_origfilename);
 968         else {
 969             Perl_croak(aTHX_ "Execution of %s aborted due to compilation errors.\n",
 970                        PL_origfilename);
 971         }
 972     }
 973     PL_curcop->cop_line = 0;
 974     PL_curstash = PL_defstash;
 975     PL_preprocess = FALSE;
 976     if (PL_e_script) {
 977         SvREFCNT_dec(PL_e_script);
 978         PL_e_script = Nullsv;
 979     }
 980
 981     /* now that script is parsed, we can modify record separator */
 982     SvREFCNT_dec(PL_rs);
 983     PL_rs = SvREFCNT_inc(PL_nrs);
 984     sv_setsv(get_sv("/", TRUE), PL_rs);
 985     if (PL_do_undump)
 986         my_unexec();
 987
 988     if (isWARN_ONCE)
 989         gv_check(PL_defstash);
 990
 991     LEAVE;
 992     FREETMPS;
 993
 994 #ifdef MYMALLOC
 995     if ((s=PerlEnv_getenv("PERL_DEBUG_MSTATS")) && atoi(s) >= 2)
 996         dump_mstats("after compilation:");
 997 #endif
 998
 999     ENTER;
1000     PL_restartop = 0;
1001     return NULL;
1002 }
1003
1004 int
1005 perl_run(pTHXx)
1006 {
1007     dTHR;
1008     I32 oldscope;
1009     int ret;
1010     dJMPENV;
1011 #ifdef USE_THREADS
1012     dTHX;
1013 #endif
1014
1015     oldscope = PL_scopestack_ix;
1016
1017  redo_body:
1018     CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_run_body), oldscope);
1019     switch (ret) {
1020     case 1:
1021         cxstack_ix = -1;                /* start context stack again */
1022         goto redo_body;
1023     case 0:  /* normal completion */
1024     case 2:  /* my_exit() */
1025         while (PL_scopestack_ix > oldscope)
1026             LEAVE;
1027         FREETMPS;
1028         PL_curstash = PL_defstash;
1029         if (PL_endav && !PL_minus_c)
1030             call_list(oldscope, PL_endav);
1031 #ifdef MYMALLOC
1032         if (PerlEnv_getenv("PERL_DEBUG_MSTATS"))
1033             dump_mstats("after execution:  ");
1034 #endif
1035         return STATUS_NATIVE_EXPORT;
1036     case 3:
1037         if (PL_restartop) {
1038             POPSTACK_TO(PL_mainstack);
1039             goto redo_body;
1040         }
1041         PerlIO_printf(Perl_error_log, "panic: restartop\n");
1042         FREETMPS;
1043         return 1;
1044     }
1045
1046     /* NOTREACHED */
1047     return 0;
1048 }
1049
1050 STATIC void *
1051 S_run_body(pTHX_ va_list args)
1052 {
1053     dTHR;
1054     I32 oldscope = va_arg(args, I32);
1055
1056     DEBUG_r(PerlIO_printf(Perl_debug_log, "%s $` $& $' support.\n",
1057                     PL_sawampersand ? "Enabling" : "Omitting"));
1058
1059     if (!PL_restartop) {
1060         DEBUG_x(dump_all());
1061         DEBUG(PerlIO_printf(Perl_debug_log, "\nEXECUTING...\n\n"));
1062         DEBUG_S(PerlIO_printf(Perl_debug_log, "main thread is 0x%lx\n",
1063                               (unsigned long) thr));
1064
1065         if (PL_minus_c) {
1066             PerlIO_printf(Perl_error_log, "%s syntax OK\n", PL_origfilename);
1067             my_exit(0);
1068         }
1069         if (PERLDB_SINGLE && PL_DBsingle)
1070             sv_setiv(PL_DBsingle, 1);
1071         if (PL_initav)
1072             call_list(oldscope, PL_initav);
1073     }
1074
1075     /* do it */
1076
1077     if (PL_restartop) {
1078         PL_op = PL_restartop;
1079         PL_restartop = 0;
1080         CALLRUNOPS(aTHX);
1081     }
1082     else if (PL_main_start) {
1083         CvDEPTH(PL_main_cv) = 1;
1084         PL_op = PL_main_start;
1085         CALLRUNOPS(aTHX);
1086     }
1087
1088     my_exit(0);
1089     /* NOTREACHED */
1090     return NULL;
1091 }
1092
1093 SV*
1094 Perl_get_sv(pTHX_ const char *name, I32 create)
1095 {
1096     GV *gv;
1097 #ifdef USE_THREADS
1098     if (name[1] == '\0' && !isALPHA(name[0])) {
1099         PADOFFSET tmp = find_threadsv(name);
1100         if (tmp != NOT_IN_PAD) {
1101             dTHR;
1102             return THREADSV(tmp);
1103         }
1104     }
1105 #endif /* USE_THREADS */
1106     gv = gv_fetchpv(name, create, SVt_PV);
1107     if (gv)
1108         return GvSV(gv);
1109     return Nullsv;
1110 }
1111
1112 AV*
1113 Perl_get_av(pTHX_ const char *name, I32 create)
1114 {
1115     GV* gv = gv_fetchpv(name, create, SVt_PVAV);
1116     if (create)
1117         return GvAVn(gv);
1118     if (gv)
1119         return GvAV(gv);
1120     return Nullav;
1121 }
1122
1123 HV*
1124 Perl_get_hv(pTHX_ const char *name, I32 create)
1125 {
1126     GV* gv = gv_fetchpv(name, create, SVt_PVHV);
1127     if (create)
1128         return GvHVn(gv);
1129     if (gv)
1130         return GvHV(gv);
1131     return Nullhv;
1132 }
1133
1134 CV*
1135 Perl_get_cv(pTHX_ const char *name, I32 create)
1136 {
1137     GV* gv = gv_fetchpv(name, create, SVt_PVCV);
1138     /* XXX unsafe for threads if eval_owner isn't held */
1139     /* XXX this is probably not what they think they're getting.
1140      * It has the same effect as "sub name;", i.e. just a forward
1141      * declaration! */
1142     if (create && !GvCVu(gv))
1143         return newSUB(start_subparse(FALSE, 0),
1144                       newSVOP(OP_CONST, 0, newSVpv(name,0)),
1145                       Nullop,
1146                       Nullop);
1147     if (gv)
1148         return GvCVu(gv);
1149     return Nullcv;
1150 }
1151
1152 /* Be sure to refetch the stack pointer after calling these routines. */
1153
1154 I32
1155 Perl_call_argv(pTHX_ const char *sub_name, I32 flags, register char **argv)
1156
1157                         /* See G_* flags in cop.h */
1158                         /* null terminated arg list */
1159 {
1160     dSP;
1161
1162     PUSHMARK(SP);
1163     if (argv) {
1164         while (*argv) {
1165             XPUSHs(sv_2mortal(newSVpv(*argv,0)));
1166             argv++;
1167         }
1168         PUTBACK;
1169     }
1170     return call_pv(sub_name, flags);
1171 }
1172
1173 I32
1174 Perl_call_pv(pTHX_ const char *sub_name, I32 flags)
1175                         /* name of the subroutine */
1176                         /* See G_* flags in cop.h */
1177 {
1178     return call_sv((SV*)get_cv(sub_name, TRUE), flags);
1179 }
1180
1181 I32
1182 Perl_call_method(pTHX_ const char *methname, I32 flags)
1183                         /* name of the subroutine */
1184                         /* See G_* flags in cop.h */
1185 {
1186     dSP;
1187     OP myop;
1188     if (!PL_op)
1189         PL_op = &myop;
1190     XPUSHs(sv_2mortal(newSVpv(methname,0)));
1191     PUTBACK;
1192     pp_method();
1193         if(PL_op == &myop)
1194                 PL_op = Nullop;
1195     return call_sv(*PL_stack_sp--, flags);
1196 }
1197
1198 /* May be called with any of a CV, a GV, or an SV containing the name. */
1199 I32
1200 Perl_call_sv(pTHX_ SV *sv, I32 flags)
1201
1202                         /* See G_* flags in cop.h */
1203 {
1204     dSP;
1205     LOGOP myop;         /* fake syntax tree node */
1206     I32 oldmark;
1207     I32 retval;
1208     I32 oldscope;
1209     bool oldcatch = CATCH_GET;
1210     int ret;
1211     OP* oldop = PL_op;
1212     dJMPENV;
1213
1214     if (flags & G_DISCARD) {
1215         ENTER;
1216         SAVETMPS;
1217     }
1218
1219     Zero(&myop, 1, LOGOP);
1220     myop.op_next = Nullop;
1221     if (!(flags & G_NOARGS))
1222         myop.op_flags |= OPf_STACKED;
1223     myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
1224                       (flags & G_ARRAY) ? OPf_WANT_LIST :
1225                       OPf_WANT_SCALAR);
1226     SAVEOP();
1227     PL_op = (OP*)&myop;
1228
1229     EXTEND(PL_stack_sp, 1);
1230     *++PL_stack_sp = sv;
1231     oldmark = TOPMARK;
1232     oldscope = PL_scopestack_ix;
1233
1234     if (PERLDB_SUB && PL_curstash != PL_debstash
1235            /* Handle first BEGIN of -d. */
1236           && (PL_DBcv || (PL_DBcv = GvCV(PL_DBsub)))
1237            /* Try harder, since this may have been a sighandler, thus
1238             * curstash may be meaningless. */
1239           && (SvTYPE(sv) != SVt_PVCV || CvSTASH((CV*)sv) != PL_debstash)
1240           && !(flags & G_NODEBUG))
1241         PL_op->op_private |= OPpENTERSUB_DB;
1242
1243     if (!(flags & G_EVAL)) {
1244         CATCH_SET(TRUE);
1245         call_xbody((OP*)&myop, FALSE);
1246         retval = PL_stack_sp - (PL_stack_base + oldmark);
1247         CATCH_SET(FALSE);
1248     }
1249     else {
1250         cLOGOP->op_other = PL_op;
1251         PL_markstack_ptr--;
1252         /* we're trying to emulate pp_entertry() here */
1253         {
1254             register PERL_CONTEXT *cx;
1255             I32 gimme = GIMME_V;
1256
1257             ENTER;
1258             SAVETMPS;
1259
1260             push_return(PL_op->op_next);
1261             PUSHBLOCK(cx, CXt_EVAL, PL_stack_sp);
1262             PUSHEVAL(cx, 0, 0);
1263             PL_eval_root = PL_op;             /* Only needed so that goto works right. */
1264
1265             PL_in_eval = EVAL_INEVAL;
1266             if (flags & G_KEEPERR)
1267                 PL_in_eval |= EVAL_KEEPERR;
1268             else
1269                 sv_setpv(ERRSV,"");
1270         }
1271         PL_markstack_ptr++;
1272
1273   redo_body:
1274         CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_call_body),
1275                     (OP*)&myop, FALSE);
1276         switch (ret) {
1277         case 0:
1278             retval = PL_stack_sp - (PL_stack_base + oldmark);
1279             if (!(flags & G_KEEPERR))
1280                 sv_setpv(ERRSV,"");
1281             break;
1282         case 1:
1283             STATUS_ALL_FAILURE;
1284             /* FALL THROUGH */
1285         case 2:
1286             /* my_exit() was called */
1287             PL_curstash = PL_defstash;
1288             FREETMPS;
1289             if (PL_statusvalue)
1290                 Perl_croak(aTHX_ "Callback called exit");
1291             my_exit_jump();
1292             /* NOTREACHED */
1293         case 3:
1294             if (PL_restartop) {
1295                 PL_op = PL_restartop;
1296                 PL_restartop = 0;
1297                 goto redo_body;
1298             }
1299             PL_stack_sp = PL_stack_base + oldmark;
1300             if (flags & G_ARRAY)
1301                 retval = 0;
1302             else {
1303                 retval = 1;
1304                 *++PL_stack_sp = &PL_sv_undef;
1305             }
1306             break;
1307         }
1308
1309         if (PL_scopestack_ix > oldscope) {
1310             SV **newsp;
1311             PMOP *newpm;
1312             I32 gimme;
1313             register PERL_CONTEXT *cx;
1314             I32 optype;
1315
1316             POPBLOCK(cx,newpm);
1317             POPEVAL(cx);
1318             pop_return();
1319             PL_curpm = newpm;
1320             LEAVE;
1321         }
1322     }
1323
1324     if (flags & G_DISCARD) {
1325         PL_stack_sp = PL_stack_base + oldmark;
1326         retval = 0;
1327         FREETMPS;
1328         LEAVE;
1329     }
1330     PL_op = oldop;
1331     return retval;
1332 }
1333
1334 STATIC void *
1335 S_call_body(pTHX_ va_list args)
1336 {
1337     OP *myop = va_arg(args, OP*);
1338     int is_eval = va_arg(args, int);
1339
1340     call_xbody(myop, is_eval);
1341     return NULL;
1342 }
1343
1344 STATIC void
1345 S_call_xbody(pTHX_ OP *myop, int is_eval)
1346 {
1347     dTHR;
1348
1349     if (PL_op == myop) {
1350         if (is_eval)
1351             PL_op = Perl_pp_entereval(aTHX);
1352         else
1353             PL_op = Perl_pp_entersub(aTHX);
1354     }
1355     if (PL_op)
1356         CALLRUNOPS(aTHX);
1357 }
1358
1359 /* Eval a string. The G_EVAL flag is always assumed. */
1360
1361 I32
1362 Perl_eval_sv(pTHX_ SV *sv, I32 flags)
1363
1364                         /* See G_* flags in cop.h */
1365 {
1366     dSP;
1367     UNOP myop;          /* fake syntax tree node */
1368     I32 oldmark = SP - PL_stack_base;
1369     I32 retval;
1370     I32 oldscope;
1371     int ret;
1372     OP* oldop = PL_op;
1373     dJMPENV;
1374
1375     if (flags & G_DISCARD) {
1376         ENTER;
1377         SAVETMPS;
1378     }
1379
1380     SAVEOP();
1381     PL_op = (OP*)&myop;
1382     Zero(PL_op, 1, UNOP);
1383     EXTEND(PL_stack_sp, 1);
1384     *++PL_stack_sp = sv;
1385     oldscope = PL_scopestack_ix;
1386
1387     if (!(flags & G_NOARGS))
1388         myop.op_flags = OPf_STACKED;
1389     myop.op_next = Nullop;
1390     myop.op_type = OP_ENTEREVAL;
1391     myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
1392                       (flags & G_ARRAY) ? OPf_WANT_LIST :
1393                       OPf_WANT_SCALAR);
1394     if (flags & G_KEEPERR)
1395         myop.op_flags |= OPf_SPECIAL;
1396
1397  redo_body:
1398     CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_call_body),
1399                 (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     PL_stderrgv = gv_fetchpv("STDERR",TRUE, SVt_PVIO);
2642     GvMULTI_on(PL_stderrgv);
2643     io = GvIOp(PL_stderrgv);
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(Perl_error_log,
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->flags = THRf_R_JOINABLE;
2925     MUTEX_INIT(&thr->mutex);
2926     /* Handcraft thrsv similarly to mess_sv */
2927     New(53, PL_thrsv, 1, SV);
2928     Newz(53, xpv, 1, XPV);
2929     SvFLAGS(PL_thrsv) = SVt_PV;
2930     SvANY(PL_thrsv) = (void*)xpv;
2931     SvREFCNT(PL_thrsv) = 1 << 30;       /* practically infinite */
2932     SvPVX(PL_thrsv) = (char*)thr;
2933     SvCUR_set(PL_thrsv, sizeof(thr));
2934     SvLEN_set(PL_thrsv, sizeof(thr));
2935     *SvEND(PL_thrsv) = '\0';    /* in the trailing_nul field */
2936     thr->oursv = PL_thrsv;
2937     PL_chopset = " \n-";
2938     PL_dumpindent = 4;
2939
2940     MUTEX_LOCK(&PL_threads_mutex);
2941     PL_nthreads++;
2942     thr->tid = 0;
2943     thr->next = thr;
2944     thr->prev = thr;
2945     MUTEX_UNLOCK(&PL_threads_mutex);
2946
2947 #ifdef HAVE_THREAD_INTERN
2948     Perl_init_thread_intern(thr);
2949 #endif
2950
2951 #ifdef SET_THREAD_SELF
2952     SET_THREAD_SELF(thr);
2953 #else
2954     thr->self = pthread_self();
2955 #endif /* SET_THREAD_SELF */
2956     SET_THR(thr);
2957
2958     /*
2959      * These must come after the SET_THR because sv_setpvn does
2960      * SvTAINT and the taint fields require dTHR.
2961      */
2962     PL_toptarget = NEWSV(0,0);
2963     sv_upgrade(PL_toptarget, SVt_PVFM);
2964     sv_setpvn(PL_toptarget, "", 0);
2965     PL_bodytarget = NEWSV(0,0);
2966     sv_upgrade(PL_bodytarget, SVt_PVFM);
2967     sv_setpvn(PL_bodytarget, "", 0);
2968     PL_formtarget = PL_bodytarget;
2969     thr->errsv = newSVpvn("", 0);
2970     (void) find_threadsv("@");  /* Ensure $@ is initialised early */
2971
2972     PL_maxscream = -1;
2973     PL_regcompp = MEMBER_TO_FPTR(Perl_pregcomp);
2974     PL_regexecp = MEMBER_TO_FPTR(Perl_regexec_flags);
2975     PL_regint_start = MEMBER_TO_FPTR(Perl_re_intuit_start);
2976     PL_regint_string = MEMBER_TO_FPTR(Perl_re_intuit_string);
2977     PL_regfree = MEMBER_TO_FPTR(Perl_pregfree);
2978     PL_regindent = 0;
2979     PL_reginterp_cnt = 0;
2980
2981     return thr;
2982 }
2983 #endif /* USE_THREADS */
2984
2985 void
2986 Perl_call_list(pTHX_ I32 oldscope, AV *paramList)
2987 {
2988     dTHR;
2989     SV *atsv = ERRSV;
2990     line_t oldline = PL_curcop->cop_line;
2991     CV *cv;
2992     STRLEN len;
2993     int ret;
2994     dJMPENV;
2995
2996     while (AvFILL(paramList) >= 0) {
2997         cv = (CV*)av_shift(paramList);
2998         SAVEFREESV(cv);
2999         CALLPROTECT(aTHX_ pcur_env, &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 && !PL_minus_c)
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(Perl_error_log, "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