perl.c

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