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