perl.c

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