perl.c

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