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