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