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