perl.c

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