perl.c

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