perl.c

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