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