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 END 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     printf("\nUsage: %s [switches] [--] [programfile] [arguments]", name);
1971     while (*p)
1972         printf("\n  %s", *p++);
1973 }
1974
1975 /* This routine handles any switches that can be given during run */
1976
1977 char *
1978 Perl_moreswitches(pTHX_ char *s)
1979 {
1980     I32 numlen;
1981     U32 rschar;
1982
1983     switch (*s) {
1984     case '0':
1985     {
1986         dTHR;
1987         numlen = 0;                     /* disallow underscores */
1988         rschar = (U32)scan_oct(s, 4, &numlen);
1989         SvREFCNT_dec(PL_nrs);
1990         if (rschar & ~((U8)~0))
1991             PL_nrs = &PL_sv_undef;
1992         else if (!rschar && numlen >= 2)
1993             PL_nrs = newSVpvn("", 0);
1994         else {
1995             char ch = rschar;
1996             PL_nrs = newSVpvn(&ch, 1);
1997         }
1998         return s + numlen;
1999     }
2000     case 'C':
2001         PL_widesyscalls = TRUE;
2002         s++;
2003         return s;
2004     case 'F':
2005         PL_minus_F = TRUE;
2006         PL_splitstr = savepv(s + 1);
2007         s += strlen(s);
2008         return s;
2009     case 'a':
2010         PL_minus_a = TRUE;
2011         s++;
2012         return s;
2013     case 'c':
2014         PL_minus_c = TRUE;
2015         s++;
2016         return s;
2017     case 'd':
2018         forbid_setid("-d");
2019         s++;
2020         if (*s == ':' || *s == '=')  {
2021             my_setenv("PERL5DB", Perl_form(aTHX_ "use Devel::%s;", ++s));
2022             s += strlen(s);
2023         }
2024         if (!PL_perldb) {
2025             PL_perldb = PERLDB_ALL;
2026             init_debugger();
2027         }
2028         return s;
2029     case 'D':
2030     {
2031 #ifdef DEBUGGING
2032         forbid_setid("-D");
2033         if (isALPHA(s[1])) {
2034             static char debopts[] = "psltocPmfrxuLHXDS";
2035             char *d;
2036
2037             for (s++; *s && (d = strchr(debopts,*s)); s++)
2038                 PL_debug |= 1 << (d - debopts);
2039         }
2040         else {
2041             PL_debug = atoi(s+1);
2042             for (s++; isDIGIT(*s); s++) ;
2043         }
2044         PL_debug |= 0x80000000;
2045 #else
2046         dTHR;
2047         if (ckWARN_d(WARN_DEBUGGING))
2048             Perl_warner(aTHX_ WARN_DEBUGGING,
2049                    "Recompile perl with -DDEBUGGING to use -D switch\n");
2050         for (s++; isALNUM(*s); s++) ;
2051 #endif
2052         /*SUPPRESS 530*/
2053         return s;
2054     }
2055     case 'h':
2056         usage(PL_origargv[0]);
2057         PerlProc_exit(0);
2058     case 'i':
2059         if (PL_inplace)
2060             Safefree(PL_inplace);
2061         PL_inplace = savepv(s+1);
2062         /*SUPPRESS 530*/
2063         for (s = PL_inplace; *s && !isSPACE(*s); s++) ;
2064         if (*s) {
2065             *s++ = '\0';
2066             if (*s == '-')      /* Additional switches on #! line. */
2067                 s++;
2068         }
2069         return s;
2070     case 'I':   /* -I handled both here and in parse_perl() */
2071         forbid_setid("-I");
2072         ++s;
2073         while (*s && isSPACE(*s))
2074             ++s;
2075         if (*s) {
2076             char *e, *p;
2077             p = s;
2078             /* ignore trailing spaces (possibly followed by other switches) */
2079             do {
2080                 for (e = p; *e && !isSPACE(*e); e++) ;
2081                 p = e;
2082                 while (isSPACE(*p))
2083                     p++;
2084             } while (*p && *p != '-');
2085             e = savepvn(s, e-s);
2086             incpush(e, TRUE, TRUE);
2087             Safefree(e);
2088             s = p;
2089             if (*s == '-')
2090                 s++;
2091         }
2092         else
2093             Perl_croak(aTHX_ "No directory specified for -I");
2094         return s;
2095     case 'l':
2096         PL_minus_l = TRUE;
2097         s++;
2098         if (PL_ors)
2099             Safefree(PL_ors);
2100         if (isDIGIT(*s)) {
2101             PL_ors = savepv("\n");
2102             PL_orslen = 1;
2103             numlen = 0;                 /* disallow underscores */
2104             *PL_ors = (char)scan_oct(s, 3 + (*s == '0'), &numlen);
2105             s += numlen;
2106         }
2107         else {
2108             dTHR;
2109             if (RsPARA(PL_nrs)) {
2110                 PL_ors = "\n\n";
2111                 PL_orslen = 2;
2112             }
2113             else
2114                 PL_ors = SvPV(PL_nrs, PL_orslen);
2115             PL_ors = savepvn(PL_ors, PL_orslen);
2116         }
2117         return s;
2118     case 'M':
2119         forbid_setid("-M");     /* XXX ? */
2120         /* FALL THROUGH */
2121     case 'm':
2122         forbid_setid("-m");     /* XXX ? */
2123         if (*++s) {
2124             char *start;
2125             SV *sv;
2126             char *use = "use ";
2127             /* -M-foo == 'no foo'       */
2128             if (*s == '-') { use = "no "; ++s; }
2129             sv = newSVpv(use,0);
2130             start = s;
2131             /* We allow -M'Module qw(Foo Bar)'  */
2132             while(isALNUM(*s) || *s==':') ++s;
2133             if (*s != '=') {
2134                 sv_catpv(sv, start);
2135                 if (*(start-1) == 'm') {
2136                     if (*s != '\0')
2137                         Perl_croak(aTHX_ "Can't use '%c' after -mname", *s);
2138                     sv_catpv( sv, " ()");
2139                 }
2140             } else {
2141                 if (s == start)
2142                     Perl_croak(aTHX_ "Module name required with -%c option",
2143                                s[-1]);
2144                 sv_catpvn(sv, start, s-start);
2145                 sv_catpv(sv, " split(/,/,q{");
2146                 sv_catpv(sv, ++s);
2147                 sv_catpv(sv,    "})");
2148             }
2149             s += strlen(s);
2150             if (!PL_preambleav)
2151                 PL_preambleav = newAV();
2152             av_push(PL_preambleav, sv);
2153         }
2154         else
2155             Perl_croak(aTHX_ "No space allowed after -%c", *(s-1));
2156         return s;
2157     case 'n':
2158         PL_minus_n = TRUE;
2159         s++;
2160         return s;
2161     case 'p':
2162         PL_minus_p = TRUE;
2163         s++;
2164         return s;
2165     case 's':
2166         forbid_setid("-s");
2167         PL_doswitches = TRUE;
2168         s++;
2169         return s;
2170     case 'T':
2171         if (!PL_tainting)
2172             Perl_croak(aTHX_ "Too late for \"-T\" option");
2173         s++;
2174         return s;
2175     case 'u':
2176         PL_do_undump = TRUE;
2177         s++;
2178         return s;
2179     case 'U':
2180         PL_unsafe = TRUE;
2181         s++;
2182         return s;
2183     case 'v':
2184         printf(Perl_form(aTHX_ "\nThis is perl, v%vd built for %s",
2185                          PL_patchlevel, ARCHNAME));
2186 #if defined(LOCAL_PATCH_COUNT)
2187         if (LOCAL_PATCH_COUNT > 0)
2188             printf("\n(with %d registered patch%s, see perl -V for more detail)",
2189                 (int)LOCAL_PATCH_COUNT, (LOCAL_PATCH_COUNT!=1) ? "es" : "");
2190 #endif
2191
2192         printf("\n\nCopyright 1987-2000, Larry Wall\n");
2193 #ifdef MSDOS
2194         printf("\nMS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n");
2195 #endif
2196 #ifdef DJGPP
2197         printf("djgpp v2 port (jpl5003c) by Hirofumi Watanabe, 1996\n");
2198         printf("djgpp v2 port (perl5004+) by Laszlo Molnar, 1997-1999\n");
2199 #endif
2200 #ifdef OS2
2201         printf("\n\nOS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n"
2202             "Version 5 port Copyright (c) 1994-1999, Andreas Kaiser, Ilya Zakharevich\n");
2203 #endif
2204 #ifdef atarist
2205         printf("atariST series port, ++jrb  bammi@cadence.com\n");
2206 #endif
2207 #ifdef __BEOS__
2208         printf("BeOS port Copyright Tom Spindler, 1997-1999\n");
2209 #endif
2210 #ifdef MPE
2211         printf("MPE/iX port Copyright by Mark Klein and Mark Bixby, 1996-1999\n");
2212 #endif
2213 #ifdef OEMVS
2214         printf("MVS (OS390) port by Mortice Kern Systems, 1997-1999\n");
2215 #endif
2216 #ifdef __VOS__
2217         printf("Stratus VOS port by Paul_Green@stratus.com, 1997-1999\n");
2218 #endif
2219 #ifdef __OPEN_VM
2220         printf("VM/ESA port by Neale Ferguson, 1998-1999\n");
2221 #endif
2222 #ifdef POSIX_BC
2223         printf("BS2000 (POSIX) port by Start Amadeus GmbH, 1998-1999\n");
2224 #endif
2225 #ifdef __MINT__
2226         printf("MiNT port by Guido Flohr, 1997-1999\n");
2227 #endif
2228 #ifdef EPOC
2229         printf("EPOC port by Olaf Flebbe, 1999-2000\n");
2230 #endif
2231 #ifdef BINARY_BUILD_NOTICE
2232         BINARY_BUILD_NOTICE;
2233 #endif
2234         printf("\n\
2235 Perl may be copied only under the terms of either the Artistic License or the\n\
2236 GNU General Public License, which may be found in the Perl 5.0 source kit.\n\n\
2237 Complete documentation for Perl, including FAQ lists, should be found on\n\
2238 this system using `man perl' or `perldoc perl'.  If you have access to the\n\
2239 Internet, point your browser at http://www.perl.com/, the Perl Home Page.\n\n");
2240         PerlProc_exit(0);
2241     case 'w':
2242         if (! (PL_dowarn & G_WARN_ALL_MASK))
2243             PL_dowarn |= G_WARN_ON;
2244         s++;
2245         return s;
2246     case 'W':
2247         PL_dowarn = G_WARN_ALL_ON|G_WARN_ON;
2248         PL_compiling.cop_warnings = pWARN_ALL ;
2249         s++;
2250         return s;
2251     case 'X':
2252         PL_dowarn = G_WARN_ALL_OFF;
2253         PL_compiling.cop_warnings = pWARN_NONE ;
2254         s++;
2255         return s;
2256     case '*':
2257     case ' ':
2258         if (s[1] == '-')        /* Additional switches on #! line. */
2259             return s+2;
2260         break;
2261     case '-':
2262     case 0:
2263 #if defined(WIN32) || !defined(PERL_STRICT_CR)
2264     case '\r':
2265 #endif
2266     case '\n':
2267     case '\t':
2268         break;
2269 #ifdef ALTERNATE_SHEBANG
2270     case 'S':                   /* OS/2 needs -S on "extproc" line. */
2271         break;
2272 #endif
2273     case 'P':
2274         if (PL_preprocess)
2275             return s+1;
2276         /* FALL THROUGH */
2277     default:
2278         Perl_croak(aTHX_ "Can't emulate -%.1s on #! line",s);
2279     }
2280     return Nullch;
2281 }
2282
2283 /* compliments of Tom Christiansen */
2284
2285 /* unexec() can be found in the Gnu emacs distribution */
2286 /* Known to work with -DUNEXEC and using unexelf.c from GNU emacs-20.2 */
2287
2288 void
2289 Perl_my_unexec(pTHX)
2290 {
2291 #ifdef UNEXEC
2292     SV*    prog;
2293     SV*    file;
2294     int    status = 1;
2295     extern int etext;
2296
2297     prog = newSVpv(BIN_EXP, 0);
2298     sv_catpv(prog, "/perl");
2299     file = newSVpv(PL_origfilename, 0);
2300     sv_catpv(file, ".perldump");
2301
2302     unexec(SvPVX(file), SvPVX(prog), &etext, sbrk(0), 0);
2303     /* unexec prints msg to stderr in case of failure */
2304     PerlProc_exit(status);
2305 #else
2306 #  ifdef VMS
2307 #    include <lib$routines.h>
2308      lib$signal(SS$_DEBUG);  /* ssdef.h #included from vmsish.h */
2309 #  else
2310     ABORT();            /* for use with undump */
2311 #  endif
2312 #endif
2313 }
2314
2315 /* initialize curinterp */
2316 STATIC void
2317 S_init_interp(pTHX)
2318 {
2319
2320 #ifdef PERL_OBJECT              /* XXX kludge */
2321 #define I_REINIT \
2322   STMT_START {                          \
2323     PL_chopset          = " \n-";       \
2324     PL_copline          = NOLINE;       \
2325     PL_curcop           = &PL_compiling;\
2326     PL_curcopdb         = NULL;         \
2327     PL_dbargs           = 0;            \
2328     PL_dumpindent       = 4;            \
2329     PL_laststatval      = -1;           \
2330     PL_laststype        = OP_STAT;      \
2331     PL_maxscream        = -1;           \
2332     PL_maxsysfd         = MAXSYSFD;     \
2333     PL_statname         = Nullsv;       \
2334     PL_tmps_floor       = -1;           \
2335     PL_tmps_ix          = -1;           \
2336     PL_op_mask          = NULL;         \
2337     PL_laststatval      = -1;           \
2338     PL_laststype        = OP_STAT;      \
2339     PL_mess_sv          = Nullsv;       \
2340     PL_splitstr         = " ";          \
2341     PL_generation       = 100;          \
2342     PL_exitlist         = NULL;         \
2343     PL_exitlistlen      = 0;            \
2344     PL_regindent        = 0;            \
2345     PL_in_clean_objs    = FALSE;        \
2346     PL_in_clean_all     = FALSE;        \
2347     PL_profiledata      = NULL;         \
2348     PL_rsfp             = Nullfp;       \
2349     PL_rsfp_filters     = Nullav;       \
2350     PL_dirty            = FALSE;        \
2351   } STMT_END
2352     I_REINIT;
2353 #else
2354 #  ifdef MULTIPLICITY
2355 #    define PERLVAR(var,type)
2356 #    define PERLVARA(var,n,type)
2357 #    if defined(PERL_IMPLICIT_CONTEXT)
2358 #      if defined(USE_THREADS)
2359 #        define PERLVARI(var,type,init)         PERL_GET_INTERP->var = init;
2360 #        define PERLVARIC(var,type,init)        PERL_GET_INTERP->var = init;
2361 #      else /* !USE_THREADS */
2362 #        define PERLVARI(var,type,init)         aTHX->var = init;
2363 #        define PERLVARIC(var,type,init)        aTHX->var = init;
2364 #      endif /* USE_THREADS */
2365 #    else
2366 #      define PERLVARI(var,type,init)   PERL_GET_INTERP->var = init;
2367 #      define PERLVARIC(var,type,init)  PERL_GET_INTERP->var = init;
2368 #    endif
2369 #    include "intrpvar.h"
2370 #    ifndef USE_THREADS
2371 #      include "thrdvar.h"
2372 #    endif
2373 #    undef PERLVAR
2374 #    undef PERLVARA
2375 #    undef PERLVARI
2376 #    undef PERLVARIC
2377 #  else
2378 #    define PERLVAR(var,type)
2379 #    define PERLVARA(var,n,type)
2380 #    define PERLVARI(var,type,init)     PL_##var = init;
2381 #    define PERLVARIC(var,type,init)    PL_##var = init;
2382 #    include "intrpvar.h"
2383 #    ifndef USE_THREADS
2384 #      include "thrdvar.h"
2385 #    endif
2386 #    undef PERLVAR
2387 #    undef PERLVARA
2388 #    undef PERLVARI
2389 #    undef PERLVARIC
2390 #  endif
2391 #endif
2392
2393 }
2394
2395 STATIC void
2396 S_init_main_stash(pTHX)
2397 {
2398     dTHR;
2399     GV *gv;
2400
2401     /* Note that strtab is a rather special HV.  Assumptions are made
2402        about not iterating on it, and not adding tie magic to it.
2403        It is properly deallocated in perl_destruct() */
2404     PL_strtab = newHV();
2405 #ifdef USE_THREADS
2406     MUTEX_INIT(&PL_strtab_mutex);
2407 #endif
2408     HvSHAREKEYS_off(PL_strtab);                 /* mandatory */
2409     hv_ksplit(PL_strtab, 512);
2410
2411     PL_curstash = PL_defstash = newHV();
2412     PL_curstname = newSVpvn("main",4);
2413     gv = gv_fetchpv("main::",TRUE, SVt_PVHV);
2414     SvREFCNT_dec(GvHV(gv));
2415     GvHV(gv) = (HV*)SvREFCNT_inc(PL_defstash);
2416     SvREADONLY_on(gv);
2417     HvNAME(PL_defstash) = savepv("main");
2418     PL_incgv = gv_HVadd(gv_AVadd(gv_fetchpv("INC",TRUE, SVt_PVAV)));
2419     GvMULTI_on(PL_incgv);
2420     PL_hintgv = gv_fetchpv("\010",TRUE, SVt_PV); /* ^H */
2421     GvMULTI_on(PL_hintgv);
2422     PL_defgv = gv_fetchpv("_",TRUE, SVt_PVAV);
2423     PL_errgv = gv_HVadd(gv_fetchpv("@", TRUE, SVt_PV));
2424     GvMULTI_on(PL_errgv);
2425     PL_replgv = gv_fetchpv("\022", TRUE, SVt_PV); /* ^R */
2426     GvMULTI_on(PL_replgv);
2427     (void)Perl_form(aTHX_ "%240s","");  /* Preallocate temp - for immediate signals. */
2428     sv_grow(ERRSV, 240);        /* Preallocate - for immediate signals. */
2429     sv_setpvn(ERRSV, "", 0);
2430     PL_curstash = PL_defstash;
2431     CopSTASH_set(&PL_compiling, PL_defstash);
2432     PL_debstash = GvHV(gv_fetchpv("DB::", GV_ADDMULTI, SVt_PVHV));
2433     PL_globalstash = GvHV(gv_fetchpv("CORE::GLOBAL::", GV_ADDMULTI, SVt_PVHV));
2434     PL_nullstash = GvHV(gv_fetchpv("<none>::", GV_ADDMULTI, SVt_PVHV));
2435     /* We must init $/ before switches are processed. */
2436     sv_setpvn(get_sv("/", TRUE), "\n", 1);
2437 }
2438
2439 STATIC void
2440 S_open_script(pTHX_ char *scriptname, bool dosearch, SV *sv, int *fdscript)
2441 {
2442     dTHR;
2443
2444     *fdscript = -1;
2445
2446     if (PL_e_script) {
2447         PL_origfilename = savepv("-e");
2448     }
2449     else {
2450         /* if find_script() returns, it returns a malloc()-ed value */
2451         PL_origfilename = scriptname = find_script(scriptname, dosearch, NULL, 1);
2452
2453         if (strnEQ(scriptname, "/dev/fd/", 8) && isDIGIT(scriptname[8]) ) {
2454             char *s = scriptname + 8;
2455             *fdscript = atoi(s);
2456             while (isDIGIT(*s))
2457                 s++;
2458             if (*s) {
2459                 scriptname = savepv(s + 1);
2460                 Safefree(PL_origfilename);
2461                 PL_origfilename = scriptname;
2462             }
2463         }
2464     }
2465
2466     CopFILE_set(PL_curcop, PL_origfilename);
2467     if (strEQ(PL_origfilename,"-"))
2468         scriptname = "";
2469     if (*fdscript >= 0) {
2470         PL_rsfp = PerlIO_fdopen(*fdscript,PERL_SCRIPT_MODE);
2471 #if defined(HAS_FCNTL) && defined(F_SETFD)
2472         if (PL_rsfp)
2473             fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,1);  /* ensure close-on-exec */
2474 #endif
2475     }
2476     else if (PL_preprocess) {
2477         char *cpp_cfg = CPPSTDIN;
2478         SV *cpp = newSVpvn("",0);
2479         SV *cmd = NEWSV(0,0);
2480
2481         if (strEQ(cpp_cfg, "cppstdin"))
2482             Perl_sv_catpvf(aTHX_ cpp, "%s/", BIN_EXP);
2483         sv_catpv(cpp, cpp_cfg);
2484
2485         sv_catpvn(sv, "-I", 2);
2486         sv_catpv(sv,PRIVLIB_EXP);
2487
2488 #ifdef MSDOS
2489         Perl_sv_setpvf(aTHX_ cmd, "\
2490 sed %s -e \"/^[^#]/b\" \
2491  -e \"/^#[      ]*include[      ]/b\" \
2492  -e \"/^#[      ]*define[       ]/b\" \
2493  -e \"/^#[      ]*if[   ]/b\" \
2494  -e \"/^#[      ]*ifdef[        ]/b\" \
2495  -e \"/^#[      ]*ifndef[       ]/b\" \
2496  -e \"/^#[      ]*else/b\" \
2497  -e \"/^#[      ]*elif[         ]/b\" \
2498  -e \"/^#[      ]*undef[        ]/b\" \
2499  -e \"/^#[      ]*endif/b\" \
2500  -e \"s/^#.*//\" \
2501  %s | %"SVf" -C %"SVf" %s",
2502           (PL_doextract ? "-e \"1,/^#/d\n\"" : ""),
2503 #else
2504 #  ifdef __OPEN_VM
2505         Perl_sv_setpvf(aTHX_ cmd, "\
2506 %s %s -e '/^[^#]/b' \
2507  -e '/^#[       ]*include[      ]/b' \
2508  -e '/^#[       ]*define[       ]/b' \
2509  -e '/^#[       ]*if[   ]/b' \
2510  -e '/^#[       ]*ifdef[        ]/b' \
2511  -e '/^#[       ]*ifndef[       ]/b' \
2512  -e '/^#[       ]*else/b' \
2513  -e '/^#[       ]*elif[         ]/b' \
2514  -e '/^#[       ]*undef[        ]/b' \
2515  -e '/^#[       ]*endif/b' \
2516  -e 's/^[       ]*#.*//' \
2517  %s | %"SVf" %"SVf" %s",
2518 #  else
2519         Perl_sv_setpvf(aTHX_ cmd, "\
2520 %s %s -e '/^[^#]/b' \
2521  -e '/^#[       ]*include[      ]/b' \
2522  -e '/^#[       ]*define[       ]/b' \
2523  -e '/^#[       ]*if[   ]/b' \
2524  -e '/^#[       ]*ifdef[        ]/b' \
2525  -e '/^#[       ]*ifndef[       ]/b' \
2526  -e '/^#[       ]*else/b' \
2527  -e '/^#[       ]*elif[         ]/b' \
2528  -e '/^#[       ]*undef[        ]/b' \
2529  -e '/^#[       ]*endif/b' \
2530  -e 's/^[       ]*#.*//' \
2531  %s | %"SVf" -C %"SVf" %s",
2532 #  endif
2533 #ifdef LOC_SED
2534           LOC_SED,
2535 #else
2536           "sed",
2537 #endif
2538           (PL_doextract ? "-e '1,/^#/d\n'" : ""),
2539 #endif
2540           scriptname, cpp, sv, CPPMINUS);
2541         PL_doextract = FALSE;
2542 #ifdef IAMSUID                          /* actually, this is caught earlier */
2543         if (PL_euid != PL_uid && !PL_euid) {    /* if running suidperl */
2544 #ifdef HAS_SETEUID
2545             (void)seteuid(PL_uid);              /* musn't stay setuid root */
2546 #else
2547 #ifdef HAS_SETREUID
2548             (void)setreuid((Uid_t)-1, PL_uid);
2549 #else
2550 #ifdef HAS_SETRESUID
2551             (void)setresuid((Uid_t)-1, PL_uid, (Uid_t)-1);
2552 #else
2553             PerlProc_setuid(PL_uid);
2554 #endif
2555 #endif
2556 #endif
2557             if (PerlProc_geteuid() != PL_uid)
2558                 Perl_croak(aTHX_ "Can't do seteuid!\n");
2559         }
2560 #endif /* IAMSUID */
2561         PL_rsfp = PerlProc_popen(SvPVX(cmd), "r");
2562         SvREFCNT_dec(cmd);
2563         SvREFCNT_dec(cpp);
2564     }
2565     else if (!*scriptname) {
2566         forbid_setid("program input from stdin");
2567         PL_rsfp = PerlIO_stdin();
2568     }
2569     else {
2570         PL_rsfp = PerlIO_open(scriptname,PERL_SCRIPT_MODE);
2571 #if defined(HAS_FCNTL) && defined(F_SETFD)
2572         if (PL_rsfp)
2573             fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,1);  /* ensure close-on-exec */
2574 #endif
2575     }
2576     if (!PL_rsfp) {
2577 #ifdef DOSUID
2578 #ifndef IAMSUID         /* in case script is not readable before setuid */
2579         if (PL_euid &&
2580             PerlLIO_stat(CopFILE(PL_curcop),&PL_statbuf) >= 0 &&
2581             PL_statbuf.st_mode & (S_ISUID|S_ISGID))
2582         {
2583             /* try again */
2584             PerlProc_execv(Perl_form(aTHX_ "%s/sperl"PERL_FS_VER_FMT, BIN_EXP,
2585                                      (int)PERL_REVISION, (int)PERL_VERSION,
2586                                      (int)PERL_SUBVERSION), PL_origargv);
2587             Perl_croak(aTHX_ "Can't do setuid\n");
2588         }
2589 #endif
2590 #endif
2591         Perl_croak(aTHX_ "Can't open perl script \"%s\": %s\n",
2592                    CopFILE(PL_curcop), Strerror(errno));
2593     }
2594 }
2595
2596 /* Mention
2597  * I_SYSSTATVFS HAS_FSTATVFS
2598  * I_SYSMOUNT
2599  * I_STATFS     HAS_FSTATFS     HAS_GETFSSTAT
2600  * I_MNTENT     HAS_GETMNTENT   HAS_HASMNTOPT
2601  * here so that metaconfig picks them up. */
2602
2603 #ifdef IAMSUID
2604 STATIC int
2605 S_fd_on_nosuid_fs(pTHX_ int fd)
2606 {
2607     int check_okay = 0; /* able to do all the required sys/libcalls */
2608     int on_nosuid  = 0; /* the fd is on a nosuid fs */
2609 /*
2610  * Preferred order: fstatvfs(), fstatfs(), ustat()+getmnt(), getmntent().
2611  * fstatvfs() is UNIX98.
2612  * fstatfs() is 4.3 BSD.
2613  * ustat()+getmnt() is pre-4.3 BSD.
2614  * getmntent() is O(number-of-mounted-filesystems) and can hang on
2615  * an irrelevant filesystem while trying to reach the right one.
2616  */
2617
2618 #undef FD_ON_NOSUID_CHECK_OKAY  /* found the syscalls to do the check? */
2619
2620 #   if !defined(FD_ON_NOSUID_CHECK_OKAY) && \
2621         defined(HAS_FSTATVFS)
2622 #   define FD_ON_NOSUID_CHECK_OKAY
2623     struct statvfs stfs;
2624
2625     check_okay = fstatvfs(fd, &stfs) == 0;
2626     on_nosuid  = check_okay && (stfs.f_flag  & ST_NOSUID);
2627 #   endif /* fstatvfs */
2628
2629 #   if !defined(FD_ON_NOSUID_CHECK_OKAY) && \
2630         defined(PERL_MOUNT_NOSUID)      && \
2631         defined(HAS_FSTATFS)            && \
2632         defined(HAS_STRUCT_STATFS)      && \
2633         defined(HAS_STRUCT_STATFS_F_FLAGS)
2634 #   define FD_ON_NOSUID_CHECK_OKAY
2635     struct statfs  stfs;
2636
2637     check_okay = fstatfs(fd, &stfs)  == 0;
2638     on_nosuid  = check_okay && (stfs.f_flags & PERL_MOUNT_NOSUID);
2639 #   endif /* fstatfs */
2640
2641 #   if !defined(FD_ON_NOSUID_CHECK_OKAY) && \
2642         defined(PERL_MOUNT_NOSUID)      && \
2643         defined(HAS_FSTAT)              && \
2644         defined(HAS_USTAT)              && \
2645         defined(HAS_GETMNT)             && \
2646         defined(HAS_STRUCT_FS_DATA)     && \
2647         defined(NOSTAT_ONE)
2648 #   define FD_ON_NOSUID_CHECK_OKAY
2649     struct stat fdst;
2650
2651     if (fstat(fd, &fdst) == 0) {
2652         struct ustat us;
2653         if (ustat(fdst.st_dev, &us) == 0) {
2654             struct fs_data fsd;
2655             /* NOSTAT_ONE here because we're not examining fields which
2656              * vary between that case and STAT_ONE. */
2657             if (getmnt((int*)0, &fsd, (int)0, NOSTAT_ONE, us.f_fname) == 0) {
2658                 size_t cmplen = sizeof(us.f_fname);
2659                 if (sizeof(fsd.fd_req.path) < cmplen)
2660                     cmplen = sizeof(fsd.fd_req.path);
2661                 if (strnEQ(fsd.fd_req.path, us.f_fname, cmplen) &&
2662                     fdst.st_dev == fsd.fd_req.dev) {
2663                         check_okay = 1;
2664                         on_nosuid = fsd.fd_req.flags & PERL_MOUNT_NOSUID;
2665                     }
2666                 }
2667             }
2668         }
2669     }
2670 #   endif /* fstat+ustat+getmnt */
2671
2672 #   if !defined(FD_ON_NOSUID_CHECK_OKAY) && \
2673         defined(HAS_GETMNTENT)          && \
2674         defined(HAS_HASMNTOPT)          && \
2675         defined(MNTOPT_NOSUID)
2676 #   define FD_ON_NOSUID_CHECK_OKAY
2677     FILE                *mtab = fopen("/etc/mtab", "r");
2678     struct mntent       *entry;
2679     struct stat         stb, fsb;
2680
2681     if (mtab && (fstat(fd, &stb) == 0)) {
2682         while (entry = getmntent(mtab)) {
2683             if (stat(entry->mnt_dir, &fsb) == 0
2684                 && fsb.st_dev == stb.st_dev)
2685             {
2686                 /* found the filesystem */
2687                 check_okay = 1;
2688                 if (hasmntopt(entry, MNTOPT_NOSUID))
2689                     on_nosuid = 1;
2690                 break;
2691             } /* A single fs may well fail its stat(). */
2692         }
2693     }
2694     if (mtab)
2695         fclose(mtab);
2696 #   endif /* getmntent+hasmntopt */
2697
2698     if (!check_okay)
2699         Perl_croak(aTHX_ "Can't check filesystem of script \"%s\" for nosuid", PL_origfilename);
2700     return on_nosuid;
2701 }
2702 #endif /* IAMSUID */
2703
2704 STATIC void
2705 S_validate_suid(pTHX_ char *validarg, char *scriptname, int fdscript)
2706 {
2707 #ifdef IAMSUID
2708     int which;
2709 #endif
2710
2711     /* do we need to emulate setuid on scripts? */
2712
2713     /* This code is for those BSD systems that have setuid #! scripts disabled
2714      * in the kernel because of a security problem.  Merely defining DOSUID
2715      * in perl will not fix that problem, but if you have disabled setuid
2716      * scripts in the kernel, this will attempt to emulate setuid and setgid
2717      * on scripts that have those now-otherwise-useless bits set.  The setuid
2718      * root version must be called suidperl or sperlN.NNN.  If regular perl
2719      * discovers that it has opened a setuid script, it calls suidperl with
2720      * the same argv that it had.  If suidperl finds that the script it has
2721      * just opened is NOT setuid root, it sets the effective uid back to the
2722      * uid.  We don't just make perl setuid root because that loses the
2723      * effective uid we had before invoking perl, if it was different from the
2724      * uid.
2725      *
2726      * DOSUID must be defined in both perl and suidperl, and IAMSUID must
2727      * be defined in suidperl only.  suidperl must be setuid root.  The
2728      * Configure script will set this up for you if you want it.
2729      */
2730
2731 #ifdef DOSUID
2732     dTHR;
2733     char *s, *s2;
2734
2735     if (PerlLIO_fstat(PerlIO_fileno(PL_rsfp),&PL_statbuf) < 0)  /* normal stat is insecure */
2736         Perl_croak(aTHX_ "Can't stat script \"%s\"",PL_origfilename);
2737     if (fdscript < 0 && PL_statbuf.st_mode & (S_ISUID|S_ISGID)) {
2738         I32 len;
2739         STRLEN n_a;
2740
2741 #ifdef IAMSUID
2742 #ifndef HAS_SETREUID
2743         /* On this access check to make sure the directories are readable,
2744          * there is actually a small window that the user could use to make
2745          * filename point to an accessible directory.  So there is a faint
2746          * chance that someone could execute a setuid script down in a
2747          * non-accessible directory.  I don't know what to do about that.
2748          * But I don't think it's too important.  The manual lies when
2749          * it says access() is useful in setuid programs.
2750          */
2751         if (PerlLIO_access(CopFILE(PL_curcop),1)) /*double check*/
2752             Perl_croak(aTHX_ "Permission denied");
2753 #else
2754         /* If we can swap euid and uid, then we can determine access rights
2755          * with a simple stat of the file, and then compare device and
2756          * inode to make sure we did stat() on the same file we opened.
2757          * Then we just have to make sure he or she can execute it.
2758          */
2759         {
2760             struct stat tmpstatbuf;
2761
2762             if (
2763 #ifdef HAS_SETREUID
2764                 setreuid(PL_euid,PL_uid) < 0
2765 #else
2766 # if HAS_SETRESUID
2767                 setresuid(PL_euid,PL_uid,(Uid_t)-1) < 0
2768 # endif
2769 #endif
2770                 || PerlProc_getuid() != PL_euid || PerlProc_geteuid() != PL_uid)
2771                 Perl_croak(aTHX_ "Can't swap uid and euid");    /* really paranoid */
2772             if (PerlLIO_stat(CopFILE(PL_curcop),&tmpstatbuf) < 0)
2773                 Perl_croak(aTHX_ "Permission denied");  /* testing full pathname here */
2774 #if defined(IAMSUID) && !defined(NO_NOSUID_CHECK)
2775             if (fd_on_nosuid_fs(PerlIO_fileno(PL_rsfp)))
2776                 Perl_croak(aTHX_ "Permission denied");
2777 #endif
2778             if (tmpstatbuf.st_dev != PL_statbuf.st_dev ||
2779                 tmpstatbuf.st_ino != PL_statbuf.st_ino) {
2780                 (void)PerlIO_close(PL_rsfp);
2781                 if (PL_rsfp = PerlProc_popen("/bin/mail root","w")) {   /* heh, heh */
2782                     PerlIO_printf(PL_rsfp,
2783 "User %"Uid_t_f" tried to run dev %ld ino %ld in place of dev %ld ino %ld!\n\
2784 (Filename of set-id script was %s, uid %"Uid_t_f" gid %"Gid_t_f".)\n\nSincerely,\nperl\n",
2785                         PL_uid,(long)tmpstatbuf.st_dev, (long)tmpstatbuf.st_ino,
2786                         (long)PL_statbuf.st_dev, (long)PL_statbuf.st_ino,
2787                         CopFILE(PL_curcop),
2788                         PL_statbuf.st_uid, PL_statbuf.st_gid);
2789                     (void)PerlProc_pclose(PL_rsfp);
2790                 }
2791                 Perl_croak(aTHX_ "Permission denied\n");
2792             }
2793             if (
2794 #ifdef HAS_SETREUID
2795               setreuid(PL_uid,PL_euid) < 0
2796 #else
2797 # if defined(HAS_SETRESUID)
2798               setresuid(PL_uid,PL_euid,(Uid_t)-1) < 0
2799 # endif
2800 #endif
2801               || PerlProc_getuid() != PL_uid || PerlProc_geteuid() != PL_euid)
2802                 Perl_croak(aTHX_ "Can't reswap uid and euid");
2803             if (!cando(S_IXUSR,FALSE,&PL_statbuf))              /* can real uid exec? */
2804                 Perl_croak(aTHX_ "Permission denied\n");
2805         }
2806 #endif /* HAS_SETREUID */
2807 #endif /* IAMSUID */
2808
2809         if (!S_ISREG(PL_statbuf.st_mode))
2810             Perl_croak(aTHX_ "Permission denied");
2811         if (PL_statbuf.st_mode & S_IWOTH)
2812             Perl_croak(aTHX_ "Setuid/gid script is writable by world");
2813         PL_doswitches = FALSE;          /* -s is insecure in suid */
2814         CopLINE_inc(PL_curcop);
2815         if (sv_gets(PL_linestr, PL_rsfp, 0) == Nullch ||
2816           strnNE(SvPV(PL_linestr,n_a),"#!",2) ) /* required even on Sys V */
2817             Perl_croak(aTHX_ "No #! line");
2818         s = SvPV(PL_linestr,n_a)+2;
2819         if (*s == ' ') s++;
2820         while (!isSPACE(*s)) s++;
2821         for (s2 = s;  (s2 > SvPV(PL_linestr,n_a)+2 &&
2822                        (isDIGIT(s2[-1]) || strchr("._-", s2[-1])));  s2--) ;
2823         if (strnNE(s2-4,"perl",4) && strnNE(s-9,"perl",4))  /* sanity check */
2824             Perl_croak(aTHX_ "Not a perl script");
2825         while (*s == ' ' || *s == '\t') s++;
2826         /*
2827          * #! arg must be what we saw above.  They can invoke it by
2828          * mentioning suidperl explicitly, but they may not add any strange
2829          * arguments beyond what #! says if they do invoke suidperl that way.
2830          */
2831         len = strlen(validarg);
2832         if (strEQ(validarg," PHOOEY ") ||
2833             strnNE(s,validarg,len) || !isSPACE(s[len]))
2834             Perl_croak(aTHX_ "Args must match #! line");
2835
2836 #ifndef IAMSUID
2837         if (PL_euid != PL_uid && (PL_statbuf.st_mode & S_ISUID) &&
2838             PL_euid == PL_statbuf.st_uid)
2839             if (!PL_do_undump)
2840                 Perl_croak(aTHX_ "YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
2841 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
2842 #endif /* IAMSUID */
2843
2844         if (PL_euid) {  /* oops, we're not the setuid root perl */
2845             (void)PerlIO_close(PL_rsfp);
2846 #ifndef IAMSUID
2847             /* try again */
2848             PerlProc_execv(Perl_form(aTHX_ "%s/sperl"PERL_FS_VER_FMT, BIN_EXP,
2849                                      (int)PERL_REVISION, (int)PERL_VERSION,
2850                                      (int)PERL_SUBVERSION), PL_origargv);
2851 #endif
2852             Perl_croak(aTHX_ "Can't do setuid\n");
2853         }
2854
2855         if (PL_statbuf.st_mode & S_ISGID && PL_statbuf.st_gid != PL_egid) {
2856 #ifdef HAS_SETEGID
2857             (void)setegid(PL_statbuf.st_gid);
2858 #else
2859 #ifdef HAS_SETREGID
2860            (void)setregid((Gid_t)-1,PL_statbuf.st_gid);
2861 #else
2862 #ifdef HAS_SETRESGID
2863            (void)setresgid((Gid_t)-1,PL_statbuf.st_gid,(Gid_t)-1);
2864 #else
2865             PerlProc_setgid(PL_statbuf.st_gid);
2866 #endif
2867 #endif
2868 #endif
2869             if (PerlProc_getegid() != PL_statbuf.st_gid)
2870                 Perl_croak(aTHX_ "Can't do setegid!\n");
2871         }
2872         if (PL_statbuf.st_mode & S_ISUID) {
2873             if (PL_statbuf.st_uid != PL_euid)
2874 #ifdef HAS_SETEUID
2875                 (void)seteuid(PL_statbuf.st_uid);       /* all that for this */
2876 #else
2877 #ifdef HAS_SETREUID
2878                 (void)setreuid((Uid_t)-1,PL_statbuf.st_uid);
2879 #else
2880 #ifdef HAS_SETRESUID
2881                 (void)setresuid((Uid_t)-1,PL_statbuf.st_uid,(Uid_t)-1);
2882 #else
2883                 PerlProc_setuid(PL_statbuf.st_uid);
2884 #endif
2885 #endif
2886 #endif
2887             if (PerlProc_geteuid() != PL_statbuf.st_uid)
2888                 Perl_croak(aTHX_ "Can't do seteuid!\n");
2889         }
2890         else if (PL_uid) {                      /* oops, mustn't run as root */
2891 #ifdef HAS_SETEUID
2892           (void)seteuid((Uid_t)PL_uid);
2893 #else
2894 #ifdef HAS_SETREUID
2895           (void)setreuid((Uid_t)-1,(Uid_t)PL_uid);
2896 #else
2897 #ifdef HAS_SETRESUID
2898           (void)setresuid((Uid_t)-1,(Uid_t)PL_uid,(Uid_t)-1);
2899 #else
2900           PerlProc_setuid((Uid_t)PL_uid);
2901 #endif
2902 #endif
2903 #endif
2904             if (PerlProc_geteuid() != PL_uid)
2905                 Perl_croak(aTHX_ "Can't do seteuid!\n");
2906         }
2907         init_ids();
2908         if (!cando(S_IXUSR,TRUE,&PL_statbuf))
2909             Perl_croak(aTHX_ "Permission denied\n");    /* they can't do this */
2910     }
2911 #ifdef IAMSUID
2912     else if (PL_preprocess)
2913         Perl_croak(aTHX_ "-P not allowed for setuid/setgid script\n");
2914     else if (fdscript >= 0)
2915         Perl_croak(aTHX_ "fd script not allowed in suidperl\n");
2916     else
2917         Perl_croak(aTHX_ "Script is not setuid/setgid in suidperl\n");
2918
2919     /* We absolutely must clear out any saved ids here, so we */
2920     /* exec the real perl, substituting fd script for scriptname. */
2921     /* (We pass script name as "subdir" of fd, which perl will grok.) */
2922     PerlIO_rewind(PL_rsfp);
2923     PerlLIO_lseek(PerlIO_fileno(PL_rsfp),(Off_t)0,0);  /* just in case rewind didn't */
2924     for (which = 1; PL_origargv[which] && PL_origargv[which] != scriptname; which++) ;
2925     if (!PL_origargv[which])
2926         Perl_croak(aTHX_ "Permission denied");
2927     PL_origargv[which] = savepv(Perl_form(aTHX_ "/dev/fd/%d/%s",
2928                                   PerlIO_fileno(PL_rsfp), PL_origargv[which]));
2929 #if defined(HAS_FCNTL) && defined(F_SETFD)
2930     fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,0);    /* ensure no close-on-exec */
2931 #endif
2932     PerlProc_execv(Perl_form(aTHX_ "%s/perl"PERL_FS_VER_FMT, BIN_EXP,
2933                              (int)PERL_REVISION, (int)PERL_VERSION,
2934                              (int)PERL_SUBVERSION), PL_origargv);/* try again */
2935     Perl_croak(aTHX_ "Can't do setuid\n");
2936 #endif /* IAMSUID */
2937 #else /* !DOSUID */
2938     if (PL_euid != PL_uid || PL_egid != PL_gid) {       /* (suidperl doesn't exist, in fact) */
2939 #ifndef SETUID_SCRIPTS_ARE_SECURE_NOW
2940         dTHR;
2941         PerlLIO_fstat(PerlIO_fileno(PL_rsfp),&PL_statbuf);      /* may be either wrapped or real suid */
2942         if ((PL_euid != PL_uid && PL_euid == PL_statbuf.st_uid && PL_statbuf.st_mode & S_ISUID)
2943             ||
2944             (PL_egid != PL_gid && PL_egid == PL_statbuf.st_gid && PL_statbuf.st_mode & S_ISGID)
2945            )
2946             if (!PL_do_undump)
2947                 Perl_croak(aTHX_ "YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
2948 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
2949 #endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
2950         /* not set-id, must be wrapped */
2951     }
2952 #endif /* DOSUID */
2953 }
2954
2955 STATIC void
2956 S_find_beginning(pTHX)
2957 {
2958     register char *s, *s2;
2959
2960     /* skip forward in input to the real script? */
2961
2962     forbid_setid("-x");
2963     while (PL_doextract) {
2964         if ((s = sv_gets(PL_linestr, PL_rsfp, 0)) == Nullch)
2965             Perl_croak(aTHX_ "No Perl script found in input\n");
2966         if (*s == '#' && s[1] == '!' && (s = instr(s,"perl"))) {
2967             PerlIO_ungetc(PL_rsfp, '\n');               /* to keep line count right */
2968             PL_doextract = FALSE;
2969             while (*s && !(isSPACE (*s) || *s == '#')) s++;
2970             s2 = s;
2971             while (*s == ' ' || *s == '\t') s++;
2972             if (*s++ == '-') {
2973                 while (isDIGIT(s2[-1]) || strchr("-._", s2[-1])) s2--;
2974                 if (strnEQ(s2-4,"perl",4))
2975                     /*SUPPRESS 530*/
2976                     while ((s = moreswitches(s)))
2977                         ;
2978             }
2979         }
2980     }
2981 }
2982
2983
2984 STATIC void
2985 S_init_ids(pTHX)
2986 {
2987     PL_uid = PerlProc_getuid();
2988     PL_euid = PerlProc_geteuid();
2989     PL_gid = PerlProc_getgid();
2990     PL_egid = PerlProc_getegid();
2991 #ifdef VMS
2992     PL_uid |= PL_gid << 16;
2993     PL_euid |= PL_egid << 16;
2994 #endif
2995     PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2996 }
2997
2998 STATIC void
2999 S_forbid_setid(pTHX_ char *s)
3000 {
3001     if (PL_euid != PL_uid)
3002         Perl_croak(aTHX_ "No %s allowed while running setuid", s);
3003     if (PL_egid != PL_gid)
3004         Perl_croak(aTHX_ "No %s allowed while running setgid", s);
3005 }
3006
3007 void
3008 Perl_init_debugger(pTHX)
3009 {
3010     dTHR;
3011     HV *ostash = PL_curstash;
3012
3013     PL_curstash = PL_debstash;
3014     PL_dbargs = GvAV(gv_AVadd((gv_fetchpv("args", GV_ADDMULTI, SVt_PVAV))));
3015     AvREAL_off(PL_dbargs);
3016     PL_DBgv = gv_fetchpv("DB", GV_ADDMULTI, SVt_PVGV);
3017     PL_DBline = gv_fetchpv("dbline", GV_ADDMULTI, SVt_PVAV);
3018     PL_DBsub = gv_HVadd(gv_fetchpv("sub", GV_ADDMULTI, SVt_PVHV));
3019     sv_upgrade(GvSV(PL_DBsub), SVt_IV); /* IVX accessed if PERLDB_SUB_NN */
3020     PL_DBsingle = GvSV((gv_fetchpv("single", GV_ADDMULTI, SVt_PV)));
3021     sv_setiv(PL_DBsingle, 0);
3022     PL_DBtrace = GvSV((gv_fetchpv("trace", GV_ADDMULTI, SVt_PV)));
3023     sv_setiv(PL_DBtrace, 0);
3024     PL_DBsignal = GvSV((gv_fetchpv("signal", GV_ADDMULTI, SVt_PV)));
3025     sv_setiv(PL_DBsignal, 0);
3026     PL_curstash = ostash;
3027 }
3028
3029 #ifndef STRESS_REALLOC
3030 #define REASONABLE(size) (size)
3031 #else
3032 #define REASONABLE(size) (1) /* unreasonable */
3033 #endif
3034
3035 void
3036 Perl_init_stacks(pTHX)
3037 {
3038     /* start with 128-item stack and 8K cxstack */
3039     PL_curstackinfo = new_stackinfo(REASONABLE(128),
3040                                  REASONABLE(8192/sizeof(PERL_CONTEXT) - 1));
3041     PL_curstackinfo->si_type = PERLSI_MAIN;
3042     PL_curstack = PL_curstackinfo->si_stack;
3043     PL_mainstack = PL_curstack;         /* remember in case we switch stacks */
3044
3045     PL_stack_base = AvARRAY(PL_curstack);
3046     PL_stack_sp = PL_stack_base;
3047     PL_stack_max = PL_stack_base + AvMAX(PL_curstack);
3048
3049     New(50,PL_tmps_stack,REASONABLE(128),SV*);
3050     PL_tmps_floor = -1;
3051     PL_tmps_ix = -1;
3052     PL_tmps_max = REASONABLE(128);
3053
3054     New(54,PL_markstack,REASONABLE(32),I32);
3055     PL_markstack_ptr = PL_markstack;
3056     PL_markstack_max = PL_markstack + REASONABLE(32);
3057
3058     SET_MARK_OFFSET;
3059
3060     New(54,PL_scopestack,REASONABLE(32),I32);
3061     PL_scopestack_ix = 0;
3062     PL_scopestack_max = REASONABLE(32);
3063
3064     New(54,PL_savestack,REASONABLE(128),ANY);
3065     PL_savestack_ix = 0;
3066     PL_savestack_max = REASONABLE(128);
3067
3068     New(54,PL_retstack,REASONABLE(16),OP*);
3069     PL_retstack_ix = 0;
3070     PL_retstack_max = REASONABLE(16);
3071 }
3072
3073 #undef REASONABLE
3074
3075 STATIC void
3076 S_nuke_stacks(pTHX)
3077 {
3078     dTHR;
3079     while (PL_curstackinfo->si_next)
3080         PL_curstackinfo = PL_curstackinfo->si_next;
3081     while (PL_curstackinfo) {
3082         PERL_SI *p = PL_curstackinfo->si_prev;
3083         /* curstackinfo->si_stack got nuked by sv_free_arenas() */
3084         Safefree(PL_curstackinfo->si_cxstack);
3085         Safefree(PL_curstackinfo);
3086         PL_curstackinfo = p;
3087     }
3088     Safefree(PL_tmps_stack);
3089     Safefree(PL_markstack);
3090     Safefree(PL_scopestack);
3091     Safefree(PL_savestack);
3092     Safefree(PL_retstack);
3093 }
3094
3095 #ifndef PERL_OBJECT
3096 static PerlIO *tmpfp;  /* moved outside init_lexer() because of UNICOS bug */
3097 #endif
3098
3099 STATIC void
3100 S_init_lexer(pTHX)
3101 {
3102 #ifdef PERL_OBJECT
3103         PerlIO *tmpfp;
3104 #endif
3105     tmpfp = PL_rsfp;
3106     PL_rsfp = Nullfp;
3107     lex_start(PL_linestr);
3108     PL_rsfp = tmpfp;
3109     PL_subname = newSVpvn("main",4);
3110 }
3111
3112 STATIC void
3113 S_init_predump_symbols(pTHX)
3114 {
3115     dTHR;
3116     GV *tmpgv;
3117     IO *io;
3118
3119     sv_setpvn(get_sv("\"", TRUE), " ", 1);
3120     PL_stdingv = gv_fetchpv("STDIN",TRUE, SVt_PVIO);
3121     GvMULTI_on(PL_stdingv);
3122     io = GvIOp(PL_stdingv);
3123     IoIFP(io) = PerlIO_stdin();
3124     tmpgv = gv_fetchpv("stdin",TRUE, SVt_PV);
3125     GvMULTI_on(tmpgv);
3126     GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io);
3127
3128     tmpgv = gv_fetchpv("STDOUT",TRUE, SVt_PVIO);
3129     GvMULTI_on(tmpgv);
3130     io = GvIOp(tmpgv);
3131     IoOFP(io) = IoIFP(io) = PerlIO_stdout();
3132     setdefout(tmpgv);
3133     tmpgv = gv_fetchpv("stdout",TRUE, SVt_PV);
3134     GvMULTI_on(tmpgv);
3135     GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io);
3136
3137     PL_stderrgv = gv_fetchpv("STDERR",TRUE, SVt_PVIO);
3138     GvMULTI_on(PL_stderrgv);
3139     io = GvIOp(PL_stderrgv);
3140     IoOFP(io) = IoIFP(io) = PerlIO_stderr();
3141     tmpgv = gv_fetchpv("stderr",TRUE, SVt_PV);
3142     GvMULTI_on(tmpgv);
3143     GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io);
3144
3145     PL_statname = NEWSV(66,0);          /* last filename we did stat on */
3146
3147     if (!PL_osname)
3148         PL_osname = savepv(OSNAME);
3149 }
3150
3151 STATIC void
3152 S_init_postdump_symbols(pTHX_ register int argc, register char **argv, register char **env)
3153 {
3154     dTHR;
3155     char *s;
3156     SV *sv;
3157     GV* tmpgv;
3158
3159     argc--,argv++;      /* skip name of script */
3160     if (PL_doswitches) {
3161         for (; argc > 0 && **argv == '-'; argc--,argv++) {
3162             if (!argv[0][1])
3163                 break;
3164             if (argv[0][1] == '-' && !argv[0][2]) {
3165                 argc--,argv++;
3166                 break;
3167             }
3168             if ((s = strchr(argv[0], '='))) {
3169                 *s++ = '\0';
3170                 sv_setpv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),s);
3171             }
3172             else
3173                 sv_setiv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),1);
3174         }
3175     }
3176     PL_toptarget = NEWSV(0,0);
3177     sv_upgrade(PL_toptarget, SVt_PVFM);
3178     sv_setpvn(PL_toptarget, "", 0);
3179     PL_bodytarget = NEWSV(0,0);
3180     sv_upgrade(PL_bodytarget, SVt_PVFM);
3181     sv_setpvn(PL_bodytarget, "", 0);
3182     PL_formtarget = PL_bodytarget;
3183
3184     TAINT;
3185     if ((tmpgv = gv_fetchpv("0",TRUE, SVt_PV))) {
3186         sv_setpv(GvSV(tmpgv),PL_origfilename);
3187         magicname("0", "0", 1);
3188     }
3189     if ((tmpgv = gv_fetchpv("\030",TRUE, SVt_PV)))
3190 #ifdef OS2
3191         sv_setpv(GvSV(tmpgv), os2_execname());
3192 #else
3193         sv_setpv(GvSV(tmpgv),PL_origargv[0]);
3194 #endif
3195     if ((PL_argvgv = gv_fetchpv("ARGV",TRUE, SVt_PVAV))) {
3196         GvMULTI_on(PL_argvgv);
3197         (void)gv_AVadd(PL_argvgv);
3198         av_clear(GvAVn(PL_argvgv));
3199         for (; argc > 0; argc--,argv++) {
3200             SV *sv = newSVpv(argv[0],0);
3201             av_push(GvAVn(PL_argvgv),sv);
3202             if (PL_widesyscalls)
3203                 sv_utf8_upgrade(sv);
3204         }
3205     }
3206     if ((PL_envgv = gv_fetchpv("ENV",TRUE, SVt_PVHV))) {
3207         HV *hv;
3208         GvMULTI_on(PL_envgv);
3209         hv = GvHVn(PL_envgv);
3210         hv_magic(hv, PL_envgv, 'E');
3211 #if !defined( VMS) && !defined(EPOC)  /* VMS doesn't have environ array */
3212         /* Note that if the supplied env parameter is actually a copy
3213            of the global environ then it may now point to free'd memory
3214            if the environment has been modified since. To avoid this
3215            problem we treat env==NULL as meaning 'use the default'
3216         */
3217         if (!env)
3218             env = environ;
3219         if (env != environ)
3220             environ[0] = Nullch;
3221         for (; *env; env++) {
3222             if (!(s = strchr(*env,'=')))
3223                 continue;
3224             *s++ = '\0';
3225 #if defined(MSDOS)
3226             (void)strupr(*env);
3227 #endif
3228             sv = newSVpv(s--,0);
3229             (void)hv_store(hv, *env, s - *env, sv, 0);
3230             *s = '=';
3231 #if defined(__BORLANDC__) && defined(USE_WIN32_RTL_ENV)
3232             /* Sins of the RTL. See note in my_setenv(). */
3233             (void)PerlEnv_putenv(savepv(*env));
3234 #endif
3235         }
3236 #endif
3237 #ifdef DYNAMIC_ENV_FETCH
3238         HvNAME(hv) = savepv(ENV_HV_NAME);
3239 #endif
3240     }
3241     TAINT_NOT;
3242     if ((tmpgv = gv_fetchpv("$",TRUE, SVt_PV)))
3243         sv_setiv(GvSV(tmpgv), (IV)PerlProc_getpid());
3244 }
3245
3246 STATIC void
3247 S_init_perllib(pTHX)
3248 {
3249     char *s;
3250     if (!PL_tainting) {
3251 #ifndef VMS
3252         s = PerlEnv_getenv("PERL5LIB");
3253         if (s)
3254             incpush(s, TRUE, TRUE);
3255         else
3256             incpush(PerlEnv_getenv("PERLLIB"), FALSE, FALSE);
3257 #else /* VMS */
3258         /* Treat PERL5?LIB as a possible search list logical name -- the
3259          * "natural" VMS idiom for a Unix path string.  We allow each
3260          * element to be a set of |-separated directories for compatibility.
3261          */
3262         char buf[256];
3263         int idx = 0;
3264         if (my_trnlnm("PERL5LIB",buf,0))
3265             do { incpush(buf,TRUE,TRUE); } while (my_trnlnm("PERL5LIB",buf,++idx));
3266         else
3267             while (my_trnlnm("PERLLIB",buf,idx++)) incpush(buf,FALSE,FALSE);
3268 #endif /* VMS */
3269     }
3270
3271 /* Use the ~-expanded versions of APPLLIB (undocumented),
3272     ARCHLIB PRIVLIB SITEARCH SITELIB VENDORARCH and VENDORLIB
3273 */
3274 #ifdef APPLLIB_EXP
3275     incpush(APPLLIB_EXP, TRUE, TRUE);
3276 #endif
3277
3278 #ifdef ARCHLIB_EXP
3279     incpush(ARCHLIB_EXP, FALSE, FALSE);
3280 #endif
3281 #ifndef PRIVLIB_EXP
3282 #  define PRIVLIB_EXP "/usr/local/lib/perl5:/usr/local/lib/perl"
3283 #endif
3284 #if defined(WIN32)
3285     incpush(PRIVLIB_EXP, TRUE, FALSE);
3286 #else
3287     incpush(PRIVLIB_EXP, FALSE, FALSE);
3288 #endif
3289
3290 #ifdef SITEARCH_EXP
3291     /* sitearch is always relative to sitelib on Windows for
3292      * DLL-based path intuition to work correctly */
3293 #  if !defined(WIN32)
3294     incpush(SITEARCH_EXP, FALSE, FALSE);
3295 #  endif
3296 #endif
3297
3298 #ifdef SITELIB_EXP
3299 #  if defined(WIN32)
3300     incpush(SITELIB_EXP, TRUE, FALSE);  /* this picks up sitearch as well */
3301 #  else
3302     incpush(SITELIB_EXP, FALSE, FALSE);
3303 #  endif
3304 #endif
3305
3306 #ifdef SITELIB_STEM /* Search for version-specific dirs below here */
3307     incpush(SITELIB_STEM, FALSE, TRUE);
3308 #endif
3309
3310 #ifdef PERL_VENDORARCH_EXP
3311     /* vendorarch is always relative to vendorlib on Windows for
3312      * DLL-based path intuition to work correctly */
3313 #  if !defined(WIN32)
3314     incpush(PERL_VENDORARCH_EXP, FALSE, FALSE);
3315 #  endif
3316 #endif
3317
3318 #ifdef PERL_VENDORLIB_EXP
3319 #  if defined(WIN32)
3320     incpush(PERL_VENDORLIB_EXP, TRUE, FALSE);   /* this picks up vendorarch as well */
3321 #  else
3322     incpush(PERL_VENDORLIB_EXP, FALSE, FALSE);
3323 #  endif
3324 #endif
3325
3326 #ifdef PERL_VENDORLIB_STEM /* Search for version-specific dirs below here */
3327     incpush(PERL_VENDORLIB_STEM, FALSE, TRUE);
3328 #endif
3329
3330 #ifdef PERL_OTHERLIBDIRS
3331     incpush(PERL_OTHERLIBDIRS, TRUE, TRUE);
3332 #endif
3333
3334     if (!PL_tainting)
3335         incpush(".", FALSE, FALSE);
3336 }
3337
3338 #if defined(DOSISH)
3339 #    define PERLLIB_SEP ';'
3340 #else
3341 #  if defined(VMS)
3342 #    define PERLLIB_SEP '|'
3343 #  else
3344 #    define PERLLIB_SEP ':'
3345 #  endif
3346 #endif
3347 #ifndef PERLLIB_MANGLE
3348 #  define PERLLIB_MANGLE(s,n) (s)
3349 #endif
3350
3351 STATIC void
3352 S_incpush(pTHX_ char *p, int addsubdirs, int addoldvers)
3353 {
3354     SV *subdir = Nullsv;
3355
3356     if (!p || !*p)
3357         return;
3358
3359     if (addsubdirs || addoldvers) {
3360         subdir = sv_newmortal();
3361     }
3362
3363     /* Break at all separators */
3364     while (p && *p) {
3365         SV *libdir = NEWSV(55,0);
3366         char *s;
3367
3368         /* skip any consecutive separators */
3369         while ( *p == PERLLIB_SEP ) {
3370             /* Uncomment the next line for PATH semantics */
3371             /* av_push(GvAVn(PL_incgv), newSVpvn(".", 1)); */
3372             p++;
3373         }
3374
3375         if ( (s = strchr(p, PERLLIB_SEP)) != Nullch ) {
3376             sv_setpvn(libdir, PERLLIB_MANGLE(p, (STRLEN)(s - p)),
3377                       (STRLEN)(s - p));
3378             p = s + 1;
3379         }
3380         else {
3381             sv_setpv(libdir, PERLLIB_MANGLE(p, 0));
3382             p = Nullch; /* break out */
3383         }
3384
3385         /*
3386          * BEFORE pushing libdir onto @INC we may first push version- and
3387          * archname-specific sub-directories.
3388          */
3389         if (addsubdirs || addoldvers) {
3390 #ifdef PERL_INC_VERSION_LIST
3391             /* Configure terminates PERL_INC_VERSION_LIST with a NULL */
3392             const char *incverlist[] = { PERL_INC_VERSION_LIST };
3393             const char **incver;
3394 #endif
3395             struct stat tmpstatbuf;
3396 #ifdef VMS
3397             char *unix;
3398             STRLEN len;
3399
3400             if ((unix = tounixspec_ts(SvPV(libdir,len),Nullch)) != Nullch) {
3401                 len = strlen(unix);
3402                 while (unix[len-1] == '/') len--;  /* Cosmetic */
3403                 sv_usepvn(libdir,unix,len);
3404             }
3405             else
3406                 PerlIO_printf(Perl_error_log,
3407                               "Failed to unixify @INC element \"%s\"\n",
3408                               SvPV(libdir,len));
3409 #endif
3410             if (addsubdirs) {
3411                 /* .../version/archname if -d .../version/archname */
3412                 Perl_sv_setpvf(aTHX_ subdir, "%"SVf"/"PERL_FS_VER_FMT"/%s",
3413                                 libdir,
3414                                (int)PERL_REVISION, (int)PERL_VERSION,
3415                                (int)PERL_SUBVERSION, ARCHNAME);
3416                 if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
3417                       S_ISDIR(tmpstatbuf.st_mode))
3418                     av_push(GvAVn(PL_incgv), newSVsv(subdir));
3419
3420                 /* .../version if -d .../version */
3421                 Perl_sv_setpvf(aTHX_ subdir, "%"SVf"/"PERL_FS_VER_FMT, libdir,
3422                                (int)PERL_REVISION, (int)PERL_VERSION,
3423                                (int)PERL_SUBVERSION);
3424                 if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
3425                       S_ISDIR(tmpstatbuf.st_mode))
3426                     av_push(GvAVn(PL_incgv), newSVsv(subdir));
3427
3428                 /* .../archname if -d .../archname */
3429                 Perl_sv_setpvf(aTHX_ subdir, "%"SVf"/%s", libdir, ARCHNAME);
3430                 if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
3431                       S_ISDIR(tmpstatbuf.st_mode))
3432                     av_push(GvAVn(PL_incgv), newSVsv(subdir));
3433             }
3434
3435 #ifdef PERL_INC_VERSION_LIST
3436             if (addoldvers) {
3437                 for (incver = incverlist; *incver; incver++) {
3438                     /* .../xxx if -d .../xxx */
3439                     Perl_sv_setpvf(aTHX_ subdir, "%"SVf"/%s", libdir, *incver);
3440                     if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
3441                           S_ISDIR(tmpstatbuf.st_mode))
3442                         av_push(GvAVn(PL_incgv), newSVsv(subdir));
3443                 }
3444             }
3445 #endif
3446         }
3447
3448         /* finally push this lib directory on the end of @INC */
3449         av_push(GvAVn(PL_incgv), libdir);
3450     }
3451 }
3452
3453 #ifdef USE_THREADS
3454 STATIC struct perl_thread *
3455 S_init_main_thread(pTHX)
3456 {
3457 #if !defined(PERL_IMPLICIT_CONTEXT)
3458     struct perl_thread *thr;
3459 #endif
3460     XPV *xpv;
3461
3462     Newz(53, thr, 1, struct perl_thread);
3463     PL_curcop = &PL_compiling;
3464     thr->interp = PERL_GET_INTERP;
3465     thr->cvcache = newHV();
3466     thr->threadsv = newAV();
3467     /* thr->threadsvp is set when find_threadsv is called */
3468     thr->specific = newAV();
3469     thr->flags = THRf_R_JOINABLE;
3470     MUTEX_INIT(&thr->mutex);
3471     /* Handcraft thrsv similarly to mess_sv */
3472     New(53, PL_thrsv, 1, SV);
3473     Newz(53, xpv, 1, XPV);
3474     SvFLAGS(PL_thrsv) = SVt_PV;
3475     SvANY(PL_thrsv) = (void*)xpv;
3476     SvREFCNT(PL_thrsv) = 1 << 30;       /* practically infinite */
3477     SvPVX(PL_thrsv) = (char*)thr;
3478     SvCUR_set(PL_thrsv, sizeof(thr));
3479     SvLEN_set(PL_thrsv, sizeof(thr));
3480     *SvEND(PL_thrsv) = '\0';    /* in the trailing_nul field */
3481     thr->oursv = PL_thrsv;
3482     PL_chopset = " \n-";
3483     PL_dumpindent = 4;
3484
3485     MUTEX_LOCK(&PL_threads_mutex);
3486     PL_nthreads++;
3487     thr->tid = 0;
3488     thr->next = thr;
3489     thr->prev = thr;
3490     MUTEX_UNLOCK(&PL_threads_mutex);
3491
3492 #ifdef HAVE_THREAD_INTERN
3493     Perl_init_thread_intern(thr);
3494 #endif
3495
3496 #ifdef SET_THREAD_SELF
3497     SET_THREAD_SELF(thr);
3498 #else
3499     thr->self = pthread_self();
3500 #endif /* SET_THREAD_SELF */
3501     PERL_SET_THX(thr);
3502
3503     /*
3504      * These must come after the SET_THR because sv_setpvn does
3505      * SvTAINT and the taint fields require dTHR.
3506      */
3507     PL_toptarget = NEWSV(0,0);
3508     sv_upgrade(PL_toptarget, SVt_PVFM);
3509     sv_setpvn(PL_toptarget, "", 0);
3510     PL_bodytarget = NEWSV(0,0);
3511     sv_upgrade(PL_bodytarget, SVt_PVFM);
3512     sv_setpvn(PL_bodytarget, "", 0);
3513     PL_formtarget = PL_bodytarget;
3514     thr->errsv = newSVpvn("", 0);
3515     (void) find_threadsv("@");  /* Ensure $@ is initialised early */
3516
3517     PL_maxscream = -1;
3518     PL_regcompp = MEMBER_TO_FPTR(Perl_pregcomp);
3519     PL_regexecp = MEMBER_TO_FPTR(Perl_regexec_flags);
3520     PL_regint_start = MEMBER_TO_FPTR(Perl_re_intuit_start);
3521     PL_regint_string = MEMBER_TO_FPTR(Perl_re_intuit_string);
3522     PL_regfree = MEMBER_TO_FPTR(Perl_pregfree);
3523     PL_regindent = 0;
3524     PL_reginterp_cnt = 0;
3525
3526     return thr;
3527 }
3528 #endif /* USE_THREADS */
3529
3530 void
3531 Perl_call_list(pTHX_ I32 oldscope, AV *paramList)
3532 {
3533     dTHR;
3534     SV *atsv;
3535     line_t oldline = CopLINE(PL_curcop);
3536     CV *cv;
3537     STRLEN len;
3538     int ret;
3539     dJMPENV;
3540
3541     while (AvFILL(paramList) >= 0) {
3542         cv = (CV*)av_shift(paramList);
3543         SAVEFREESV(cv);
3544 #ifdef PERL_FLEXIBLE_EXCEPTIONS
3545         CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_vcall_list_body), cv);
3546 #else
3547         JMPENV_PUSH(ret);
3548 #endif
3549         switch (ret) {
3550         case 0:
3551 #ifndef PERL_FLEXIBLE_EXCEPTIONS
3552             call_list_body(cv);
3553 #endif
3554             atsv = ERRSV;
3555             (void)SvPV(atsv, len);
3556             if (len) {
3557                 STRLEN n_a;
3558                 PL_curcop = &PL_compiling;
3559                 CopLINE_set(PL_curcop, oldline);
3560                 if (paramList == PL_beginav)
3561                     sv_catpv(atsv, "BEGIN failed--compilation aborted");
3562                 else
3563                     Perl_sv_catpvf(aTHX_ atsv,
3564                                    "%s failed--call queue aborted",
3565                                    paramList == PL_checkav ? "CHECK"
3566                                    : paramList == PL_initav ? "INIT"
3567                                    : "END");
3568                 while (PL_scopestack_ix > oldscope)
3569                     LEAVE;
3570                 JMPENV_POP;
3571                 Perl_croak(aTHX_ "%s", SvPVx(atsv, n_a));
3572             }
3573             break;
3574         case 1:
3575             STATUS_ALL_FAILURE;
3576             /* FALL THROUGH */
3577         case 2:
3578             /* my_exit() was called */
3579             while (PL_scopestack_ix > oldscope)
3580                 LEAVE;
3581             FREETMPS;
3582             PL_curstash = PL_defstash;
3583             PL_curcop = &PL_compiling;
3584             CopLINE_set(PL_curcop, oldline);
3585             JMPENV_POP;
3586             if (PL_statusvalue && !(PL_exit_flags & PERL_EXIT_EXPECTED)) {
3587                 if (paramList == PL_beginav)
3588                     Perl_croak(aTHX_ "BEGIN failed--compilation aborted");
3589                 else
3590                     Perl_croak(aTHX_ "%s failed--call queue aborted",
3591                                paramList == PL_checkav ? "CHECK"
3592                                : paramList == PL_initav ? "INIT"
3593                                : "END");
3594             }
3595             my_exit_jump();
3596             /* NOTREACHED */
3597         case 3:
3598             if (PL_restartop) {
3599                 PL_curcop = &PL_compiling;
3600                 CopLINE_set(PL_curcop, oldline);
3601                 JMPENV_JUMP(3);
3602             }
3603             PerlIO_printf(Perl_error_log, "panic: restartop\n");
3604             FREETMPS;
3605             break;
3606         }
3607         JMPENV_POP;
3608     }
3609 }
3610
3611 #ifdef PERL_FLEXIBLE_EXCEPTIONS
3612 STATIC void *
3613 S_vcall_list_body(pTHX_ va_list args)
3614 {
3615     CV *cv = va_arg(args, CV*);
3616     return call_list_body(cv);
3617 }
3618 #endif
3619
3620 STATIC void *
3621 S_call_list_body(pTHX_ CV *cv)
3622 {
3623     PUSHMARK(PL_stack_sp);
3624     call_sv((SV*)cv, G_EVAL|G_DISCARD);
3625     return NULL;
3626 }
3627
3628 void
3629 Perl_my_exit(pTHX_ U32 status)
3630 {
3631     dTHR;
3632
3633     DEBUG_S(PerlIO_printf(Perl_debug_log, "my_exit: thread %p, status %lu\n",
3634                           thr, (unsigned long) status));
3635     switch (status) {
3636     case 0:
3637         STATUS_ALL_SUCCESS;
3638         break;
3639     case 1:
3640         STATUS_ALL_FAILURE;
3641         break;
3642     default:
3643         STATUS_NATIVE_SET(status);
3644         break;
3645     }
3646     my_exit_jump();
3647 }
3648
3649 void
3650 Perl_my_failure_exit(pTHX)
3651 {
3652 #ifdef VMS
3653     if (vaxc$errno & 1) {
3654         if (STATUS_NATIVE & 1)          /* fortuitiously includes "-1" */
3655             STATUS_NATIVE_SET(44);
3656     }
3657     else {
3658         if (!vaxc$errno && errno)       /* unlikely */
3659             STATUS_NATIVE_SET(44);
3660         else
3661             STATUS_NATIVE_SET(vaxc$errno);
3662     }
3663 #else
3664     int exitstatus;
3665     if (errno & 255)
3666         STATUS_POSIX_SET(errno);
3667     else {
3668         exitstatus = STATUS_POSIX >> 8;
3669         if (exitstatus & 255)
3670             STATUS_POSIX_SET(exitstatus);
3671         else
3672             STATUS_POSIX_SET(255);
3673     }
3674 #endif
3675     my_exit_jump();
3676 }
3677
3678 STATIC void
3679 S_my_exit_jump(pTHX)
3680 {
3681     dTHR;
3682     register PERL_CONTEXT *cx;
3683     I32 gimme;
3684     SV **newsp;
3685
3686     if (PL_e_script) {
3687         SvREFCNT_dec(PL_e_script);
3688         PL_e_script = Nullsv;
3689     }
3690
3691     POPSTACK_TO(PL_mainstack);
3692     if (cxstack_ix >= 0) {
3693         if (cxstack_ix > 0)
3694             dounwind(0);
3695         POPBLOCK(cx,PL_curpm);
3696         LEAVE;
3697     }
3698
3699     JMPENV_JUMP(2);
3700 }
3701
3702 #ifdef PERL_OBJECT
3703 #include "XSUB.h"
3704 #endif
3705
3706 static I32
3707 read_e_script(pTHXo_ int idx, SV *buf_sv, int maxlen)
3708 {
3709     char *p, *nl;
3710     p  = SvPVX(PL_e_script);
3711     nl = strchr(p, '\n');
3712     nl = (nl) ? nl+1 : SvEND(PL_e_script);
3713     if (nl-p == 0) {
3714         filter_del(read_e_script);
3715         return 0;
3716     }
3717     sv_catpvn(buf_sv, p, nl-p);
3718     sv_chop(PL_e_script, nl);
3719     return 1;
3720 }