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