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