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