perl.c

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