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