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