perl.c

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