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