perl.c

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