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