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