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