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