perl.c

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