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