perl.c

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