perl.c

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