perl.c

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