perl.c

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