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%s syntax OK\n",
1652                 (gMacPerl_ErrorFormat ? "# " : ""),
1653                 MacPerl_MPWFileName(PL_origfilename));
1654 #else
1655             PerlIO_printf(Perl_error_log, "%s syntax OK\n", PL_origfilename);
1656 #endif
1657             my_exit(0);
1658         }
1659         if (PERLDB_SINGLE && PL_DBsingle)
1660             sv_setiv(PL_DBsingle, 1);
1661         if (PL_initav)
1662             call_list(oldscope, PL_initav);
1663     }
1664
1665     /* do it */
1666
1667     if (PL_restartop) {
1668         PL_op = PL_restartop;
1669         PL_restartop = 0;
1670         CALLRUNOPS(aTHX);
1671     }
1672     else if (PL_main_start) {
1673         CvDEPTH(PL_main_cv) = 1;
1674         PL_op = PL_main_start;
1675         CALLRUNOPS(aTHX);
1676     }
1677
1678     my_exit(0);
1679     /* NOTREACHED */
1680     return NULL;
1681 }
1682
1683 /*
1684 =head1 SV Manipulation Functions
1685
1686 =for apidoc p||get_sv
1687
1688 Returns the SV of the specified Perl scalar.  If C<create> is set and the
1689 Perl variable does not exist then it will be created.  If C<create> is not
1690 set and the variable does not exist then NULL is returned.
1691
1692 =cut
1693 */
1694
1695 SV*
1696 Perl_get_sv(pTHX_ const char *name, I32 create)
1697 {
1698     GV *gv;
1699 #ifdef USE_5005THREADS
1700     if (name[1] == '\0' && !isALPHA(name[0])) {
1701         PADOFFSET tmp = find_threadsv(name);
1702         if (tmp != NOT_IN_PAD)
1703             return THREADSV(tmp);
1704     }
1705 #endif /* USE_5005THREADS */
1706     gv = gv_fetchpv(name, create, SVt_PV);
1707     if (gv)
1708         return GvSV(gv);
1709     return Nullsv;
1710 }
1711
1712 /*
1713 =head1 Array Manipulation Functions
1714
1715 =for apidoc p||get_av
1716
1717 Returns the AV of the specified Perl array.  If C<create> is set and the
1718 Perl variable does not exist then it will be created.  If C<create> is not
1719 set and the variable does not exist then NULL is returned.
1720
1721 =cut
1722 */
1723
1724 AV*
1725 Perl_get_av(pTHX_ const char *name, I32 create)
1726 {
1727     GV* gv = gv_fetchpv(name, create, SVt_PVAV);
1728     if (create)
1729         return GvAVn(gv);
1730     if (gv)
1731         return GvAV(gv);
1732     return Nullav;
1733 }
1734
1735 /*
1736 =head1 Hash Manipulation Functions
1737
1738 =for apidoc p||get_hv
1739
1740 Returns the HV of the specified Perl hash.  If C<create> is set and the
1741 Perl variable does not exist then it will be created.  If C<create> is not
1742 set and the variable does not exist then NULL is returned.
1743
1744 =cut
1745 */
1746
1747 HV*
1748 Perl_get_hv(pTHX_ const char *name, I32 create)
1749 {
1750     GV* gv = gv_fetchpv(name, create, SVt_PVHV);
1751     if (create)
1752         return GvHVn(gv);
1753     if (gv)
1754         return GvHV(gv);
1755     return Nullhv;
1756 }
1757
1758 /*
1759 =head1 CV Manipulation Functions
1760
1761 =for apidoc p||get_cv
1762
1763 Returns the CV of the specified Perl subroutine.  If C<create> is set and
1764 the Perl subroutine does not exist then it will be declared (which has the
1765 same effect as saying C<sub name;>).  If C<create> is not set and the
1766 subroutine does not exist then NULL is returned.
1767
1768 =cut
1769 */
1770
1771 CV*
1772 Perl_get_cv(pTHX_ const char *name, I32 create)
1773 {
1774     GV* gv = gv_fetchpv(name, create, SVt_PVCV);
1775     /* XXX unsafe for threads if eval_owner isn't held */
1776     /* XXX this is probably not what they think they're getting.
1777      * It has the same effect as "sub name;", i.e. just a forward
1778      * declaration! */
1779     if (create && !GvCVu(gv))
1780         return newSUB(start_subparse(FALSE, 0),
1781                       newSVOP(OP_CONST, 0, newSVpv(name,0)),
1782                       Nullop,
1783                       Nullop);
1784     if (gv)
1785         return GvCVu(gv);
1786     return Nullcv;
1787 }
1788
1789 /* Be sure to refetch the stack pointer after calling these routines. */
1790
1791 /*
1792
1793 =head1 Callback Functions
1794
1795 =for apidoc p||call_argv
1796
1797 Performs a callback to the specified Perl sub.  See L<perlcall>.
1798
1799 =cut
1800 */
1801
1802 I32
1803 Perl_call_argv(pTHX_ const char *sub_name, I32 flags, register char **argv)
1804
1805                         /* See G_* flags in cop.h */
1806                         /* null terminated arg list */
1807 {
1808     dSP;
1809
1810     PUSHMARK(SP);
1811     if (argv) {
1812         while (*argv) {
1813             XPUSHs(sv_2mortal(newSVpv(*argv,0)));
1814             argv++;
1815         }
1816         PUTBACK;
1817     }
1818     return call_pv(sub_name, flags);
1819 }
1820
1821 /*
1822 =for apidoc p||call_pv
1823
1824 Performs a callback to the specified Perl sub.  See L<perlcall>.
1825
1826 =cut
1827 */
1828
1829 I32
1830 Perl_call_pv(pTHX_ const char *sub_name, I32 flags)
1831                         /* name of the subroutine */
1832                         /* See G_* flags in cop.h */
1833 {
1834     return call_sv((SV*)get_cv(sub_name, TRUE), flags);
1835 }
1836
1837 /*
1838 =for apidoc p||call_method
1839
1840 Performs a callback to the specified Perl method.  The blessed object must
1841 be on the stack.  See L<perlcall>.
1842
1843 =cut
1844 */
1845
1846 I32
1847 Perl_call_method(pTHX_ const char *methname, I32 flags)
1848                         /* name of the subroutine */
1849                         /* See G_* flags in cop.h */
1850 {
1851     return call_sv(sv_2mortal(newSVpv(methname,0)), flags | G_METHOD);
1852 }
1853
1854 /* May be called with any of a CV, a GV, or an SV containing the name. */
1855 /*
1856 =for apidoc p||call_sv
1857
1858 Performs a callback to the Perl sub whose name is in the SV.  See
1859 L<perlcall>.
1860
1861 =cut
1862 */
1863
1864 I32
1865 Perl_call_sv(pTHX_ SV *sv, I32 flags)
1866                         /* See G_* flags in cop.h */
1867 {
1868     dSP;
1869     LOGOP myop;         /* fake syntax tree node */
1870     UNOP method_op;
1871     I32 oldmark;
1872     volatile I32 retval = 0;
1873     I32 oldscope;
1874     bool oldcatch = CATCH_GET;
1875     int ret;
1876     OP* oldop = PL_op;
1877     dJMPENV;
1878
1879     if (flags & G_DISCARD) {
1880         ENTER;
1881         SAVETMPS;
1882     }
1883
1884     Zero(&myop, 1, LOGOP);
1885     myop.op_next = Nullop;
1886     if (!(flags & G_NOARGS))
1887         myop.op_flags |= OPf_STACKED;
1888     myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
1889                       (flags & G_ARRAY) ? OPf_WANT_LIST :
1890                       OPf_WANT_SCALAR);
1891     SAVEOP();
1892     PL_op = (OP*)&myop;
1893
1894     EXTEND(PL_stack_sp, 1);
1895     *++PL_stack_sp = sv;
1896     oldmark = TOPMARK;
1897     oldscope = PL_scopestack_ix;
1898
1899     if (PERLDB_SUB && PL_curstash != PL_debstash
1900            /* Handle first BEGIN of -d. */
1901           && (PL_DBcv || (PL_DBcv = GvCV(PL_DBsub)))
1902            /* Try harder, since this may have been a sighandler, thus
1903             * curstash may be meaningless. */
1904           && (SvTYPE(sv) != SVt_PVCV || CvSTASH((CV*)sv) != PL_debstash)
1905           && !(flags & G_NODEBUG))
1906         PL_op->op_private |= OPpENTERSUB_DB;
1907
1908     if (flags & G_METHOD) {
1909         Zero(&method_op, 1, UNOP);
1910         method_op.op_next = PL_op;
1911         method_op.op_ppaddr = PL_ppaddr[OP_METHOD];
1912         myop.op_ppaddr = PL_ppaddr[OP_ENTERSUB];
1913         PL_op = (OP*)&method_op;
1914     }
1915
1916     if (!(flags & G_EVAL)) {
1917         CATCH_SET(TRUE);
1918         call_body((OP*)&myop, FALSE);
1919         retval = PL_stack_sp - (PL_stack_base + oldmark);
1920         CATCH_SET(oldcatch);
1921     }
1922     else {
1923         myop.op_other = (OP*)&myop;
1924         PL_markstack_ptr--;
1925         /* we're trying to emulate pp_entertry() here */
1926         {
1927             register PERL_CONTEXT *cx;
1928             I32 gimme = GIMME_V;
1929
1930             ENTER;
1931             SAVETMPS;
1932
1933             push_return(Nullop);
1934             PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), PL_stack_sp);
1935             PUSHEVAL(cx, 0, 0);
1936             PL_eval_root = PL_op;             /* Only needed so that goto works right. */
1937
1938             PL_in_eval = EVAL_INEVAL;
1939             if (flags & G_KEEPERR)
1940                 PL_in_eval |= EVAL_KEEPERR;
1941             else
1942                 sv_setpv(ERRSV,"");
1943         }
1944         PL_markstack_ptr++;
1945
1946 #ifdef PERL_FLEXIBLE_EXCEPTIONS
1947  redo_body:
1948         CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_vcall_body),
1949                     (OP*)&myop, FALSE);
1950 #else
1951         JMPENV_PUSH(ret);
1952 #endif
1953         switch (ret) {
1954         case 0:
1955 #ifndef PERL_FLEXIBLE_EXCEPTIONS
1956  redo_body:
1957             call_body((OP*)&myop, FALSE);
1958 #endif
1959             retval = PL_stack_sp - (PL_stack_base + oldmark);
1960             if (!(flags & G_KEEPERR))
1961                 sv_setpv(ERRSV,"");
1962             break;
1963         case 1:
1964             STATUS_ALL_FAILURE;
1965             /* FALL THROUGH */
1966         case 2:
1967             /* my_exit() was called */
1968             PL_curstash = PL_defstash;
1969             FREETMPS;
1970             JMPENV_POP;
1971             if (PL_statusvalue && !(PL_exit_flags & PERL_EXIT_EXPECTED))
1972                 Perl_croak(aTHX_ "Callback called exit");
1973             my_exit_jump();
1974             /* NOTREACHED */
1975         case 3:
1976             if (PL_restartop) {
1977                 PL_op = PL_restartop;
1978                 PL_restartop = 0;
1979                 goto redo_body;
1980             }
1981             PL_stack_sp = PL_stack_base + oldmark;
1982             if (flags & G_ARRAY)
1983                 retval = 0;
1984             else {
1985                 retval = 1;
1986                 *++PL_stack_sp = &PL_sv_undef;
1987             }
1988             break;
1989         }
1990
1991         if (PL_scopestack_ix > oldscope) {
1992             SV **newsp;
1993             PMOP *newpm;
1994             I32 gimme;
1995             register PERL_CONTEXT *cx;
1996             I32 optype;
1997
1998             POPBLOCK(cx,newpm);
1999             POPEVAL(cx);
2000             pop_return();
2001             PL_curpm = newpm;
2002             LEAVE;
2003         }
2004         JMPENV_POP;
2005     }
2006
2007     if (flags & G_DISCARD) {
2008         PL_stack_sp = PL_stack_base + oldmark;
2009         retval = 0;
2010         FREETMPS;
2011         LEAVE;
2012     }
2013     PL_op = oldop;
2014     return retval;
2015 }
2016
2017 #ifdef PERL_FLEXIBLE_EXCEPTIONS
2018 STATIC void *
2019 S_vcall_body(pTHX_ va_list args)
2020 {
2021     OP *myop = va_arg(args, OP*);
2022     int is_eval = va_arg(args, int);
2023
2024     call_body(myop, is_eval);
2025     return NULL;
2026 }
2027 #endif
2028
2029 STATIC void
2030 S_call_body(pTHX_ OP *myop, int is_eval)
2031 {
2032     if (PL_op == myop) {
2033         if (is_eval)
2034             PL_op = Perl_pp_entereval(aTHX);    /* this doesn't do a POPMARK */
2035         else
2036             PL_op = Perl_pp_entersub(aTHX);     /* this does */
2037     }
2038     if (PL_op)
2039         CALLRUNOPS(aTHX);
2040 }
2041
2042 /* Eval a string. The G_EVAL flag is always assumed. */
2043
2044 /*
2045 =for apidoc p||eval_sv
2046
2047 Tells Perl to C<eval> the string in the SV.
2048
2049 =cut
2050 */
2051
2052 I32
2053 Perl_eval_sv(pTHX_ SV *sv, I32 flags)
2054
2055                         /* See G_* flags in cop.h */
2056 {
2057     dSP;
2058     UNOP myop;          /* fake syntax tree node */
2059     volatile I32 oldmark = SP - PL_stack_base;
2060     volatile I32 retval = 0;
2061     I32 oldscope;
2062     int ret;
2063     OP* oldop = PL_op;
2064     dJMPENV;
2065
2066     if (flags & G_DISCARD) {
2067         ENTER;
2068         SAVETMPS;
2069     }
2070
2071     SAVEOP();
2072     PL_op = (OP*)&myop;
2073     Zero(PL_op, 1, UNOP);
2074     EXTEND(PL_stack_sp, 1);
2075     *++PL_stack_sp = sv;
2076     oldscope = PL_scopestack_ix;
2077
2078     if (!(flags & G_NOARGS))
2079         myop.op_flags = OPf_STACKED;
2080     myop.op_next = Nullop;
2081     myop.op_type = OP_ENTEREVAL;
2082     myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
2083                       (flags & G_ARRAY) ? OPf_WANT_LIST :
2084                       OPf_WANT_SCALAR);
2085     if (flags & G_KEEPERR)
2086         myop.op_flags |= OPf_SPECIAL;
2087
2088 #ifdef PERL_FLEXIBLE_EXCEPTIONS
2089  redo_body:
2090     CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_vcall_body),
2091                 (OP*)&myop, TRUE);
2092 #else
2093     JMPENV_PUSH(ret);
2094 #endif
2095     switch (ret) {
2096     case 0:
2097 #ifndef PERL_FLEXIBLE_EXCEPTIONS
2098  redo_body:
2099         call_body((OP*)&myop,TRUE);
2100 #endif
2101         retval = PL_stack_sp - (PL_stack_base + oldmark);
2102         if (!(flags & G_KEEPERR))
2103             sv_setpv(ERRSV,"");
2104         break;
2105     case 1:
2106         STATUS_ALL_FAILURE;
2107         /* FALL THROUGH */
2108     case 2:
2109         /* my_exit() was called */
2110         PL_curstash = PL_defstash;
2111         FREETMPS;
2112         JMPENV_POP;
2113         if (PL_statusvalue && !(PL_exit_flags & PERL_EXIT_EXPECTED))
2114             Perl_croak(aTHX_ "Callback called exit");
2115         my_exit_jump();
2116         /* NOTREACHED */
2117     case 3:
2118         if (PL_restartop) {
2119             PL_op = PL_restartop;
2120             PL_restartop = 0;
2121             goto redo_body;
2122         }
2123         PL_stack_sp = PL_stack_base + oldmark;
2124         if (flags & G_ARRAY)
2125             retval = 0;
2126         else {
2127             retval = 1;
2128             *++PL_stack_sp = &PL_sv_undef;
2129         }
2130         break;
2131     }
2132
2133     JMPENV_POP;
2134     if (flags & G_DISCARD) {
2135         PL_stack_sp = PL_stack_base + oldmark;
2136         retval = 0;
2137         FREETMPS;
2138         LEAVE;
2139     }
2140     PL_op = oldop;
2141     return retval;
2142 }
2143
2144 /*
2145 =for apidoc p||eval_pv
2146
2147 Tells Perl to C<eval> the given string and return an SV* result.
2148
2149 =cut
2150 */
2151
2152 SV*
2153 Perl_eval_pv(pTHX_ const char *p, I32 croak_on_error)
2154 {
2155     dSP;
2156     SV* sv = newSVpv(p, 0);
2157
2158     eval_sv(sv, G_SCALAR);
2159     SvREFCNT_dec(sv);
2160
2161     SPAGAIN;
2162     sv = POPs;
2163     PUTBACK;
2164
2165     if (croak_on_error && SvTRUE(ERRSV)) {
2166         STRLEN n_a;
2167         Perl_croak(aTHX_ SvPVx(ERRSV, n_a));
2168     }
2169
2170     return sv;
2171 }
2172
2173 /* Require a module. */
2174
2175 /*
2176 =head1 Embedding Functions
2177
2178 =for apidoc p||require_pv
2179
2180 Tells Perl to C<require> the file named by the string argument.  It is
2181 analogous to the Perl code C<eval "require '$file'">.  It's even
2182 implemented that way; consider using Perl_load_module instead.
2183
2184 =cut */
2185
2186 void
2187 Perl_require_pv(pTHX_ const char *pv)
2188 {
2189     SV* sv;
2190     dSP;
2191     PUSHSTACKi(PERLSI_REQUIRE);
2192     PUTBACK;
2193     sv = sv_newmortal();
2194     sv_setpv(sv, "require '");
2195     sv_catpv(sv, pv);
2196     sv_catpv(sv, "'");
2197     eval_sv(sv, G_DISCARD);
2198     SPAGAIN;
2199     POPSTACK;
2200 }
2201
2202 void
2203 Perl_magicname(pTHX_ char *sym, char *name, I32 namlen)
2204 {
2205     register GV *gv;
2206
2207     if ((gv = gv_fetchpv(sym,TRUE, SVt_PV)))
2208         sv_magic(GvSV(gv), (SV*)gv, PERL_MAGIC_sv, name, namlen);
2209 }
2210
2211 STATIC void
2212 S_usage(pTHX_ char *name)               /* XXX move this out into a module ? */
2213 {
2214     /* This message really ought to be max 23 lines.
2215      * Removed -h because the user already knows that option. Others? */
2216
2217     static char *usage_msg[] = {
2218 "-0[octal]       specify record separator (\\0, if no argument)",
2219 "-a              autosplit mode with -n or -p (splits $_ into @F)",
2220 "-C              enable native wide character system interfaces",
2221 "-c              check syntax only (runs BEGIN and CHECK blocks)",
2222 "-d[:debugger]   run program under debugger",
2223 "-D[number/list] set debugging flags (argument is a bit mask or alphabets)",
2224 "-e 'command'    one line of program (several -e's allowed, omit programfile)",
2225 "-F/pattern/     split() pattern for -a switch (//'s are optional)",
2226 "-i[extension]   edit <> files in place (makes backup if extension supplied)",
2227 "-Idirectory     specify @INC/#include directory (several -I's allowed)",
2228 "-l[octal]       enable line ending processing, specifies line terminator",
2229 "-[mM][-]module  execute `use/no module...' before executing program",
2230 "-n              assume 'while (<>) { ... }' loop around program",
2231 "-p              assume loop like -n but print line also, like sed",
2232 "-P              run program through C preprocessor before compilation",
2233 "-s              enable rudimentary parsing for switches after programfile",
2234 "-S              look for programfile using PATH environment variable",
2235 "-T              enable tainting checks",
2236 "-t              enable tainting warnings",
2237 "-u              dump core after parsing program",
2238 "-U              allow unsafe operations",
2239 "-v              print version, subversion (includes VERY IMPORTANT perl info)",
2240 "-V[:variable]   print configuration summary (or a single Config.pm variable)",
2241 "-w              enable many useful warnings (RECOMMENDED)",
2242 "-W              enable all warnings",
2243 "-X              disable all warnings",
2244 "-x[directory]   strip off text before #!perl line and perhaps cd to directory",
2245 "\n",
2246 NULL
2247 };
2248     char **p = usage_msg;
2249
2250     PerlIO_printf(PerlIO_stdout(),
2251                   "\nUsage: %s [switches] [--] [programfile] [arguments]",
2252                   name);
2253     while (*p)
2254         PerlIO_printf(PerlIO_stdout(), "\n  %s", *p++);
2255 }
2256
2257 /* This routine handles any switches that can be given during run */
2258
2259 char *
2260 Perl_moreswitches(pTHX_ char *s)
2261 {
2262     STRLEN numlen;
2263     U32 rschar;
2264
2265     switch (*s) {
2266     case '0':
2267     {
2268         I32 flags = 0;
2269         numlen = 4;
2270         rschar = (U32)grok_oct(s, &numlen, &flags, NULL);
2271         SvREFCNT_dec(PL_rs);
2272         if (rschar & ~((U8)~0))
2273             PL_rs = &PL_sv_undef;
2274         else if (!rschar && numlen >= 2)
2275             PL_rs = newSVpvn("", 0);
2276         else {
2277             char ch = (char)rschar;
2278             PL_rs = newSVpvn(&ch, 1);
2279         }
2280         return s + numlen;
2281     }
2282     case 'C':
2283         PL_widesyscalls = TRUE;
2284         s++;
2285         return s;
2286     case 'F':
2287         PL_minus_F = TRUE;
2288         PL_splitstr = ++s;
2289         while (*s && !isSPACE(*s)) ++s;
2290         *s = '\0';
2291         PL_splitstr = savepv(PL_splitstr);
2292         return s;
2293     case 'a':
2294         PL_minus_a = TRUE;
2295         s++;
2296         return s;
2297     case 'c':
2298         PL_minus_c = TRUE;
2299         s++;
2300         return s;
2301     case 'd':
2302         forbid_setid("-d");
2303         s++;
2304         /* The following permits -d:Mod to accepts arguments following an =
2305            in the fashion that -MSome::Mod does. */
2306         if (*s == ':' || *s == '=') {
2307             char *start;
2308             SV *sv;
2309             sv = newSVpv("use Devel::", 0);
2310             start = ++s;
2311             /* We now allow -d:Module=Foo,Bar */
2312             while(isALNUM(*s) || *s==':') ++s;
2313             if (*s != '=')
2314                 sv_catpv(sv, start);
2315             else {
2316                 sv_catpvn(sv, start, s-start);
2317                 sv_catpv(sv, " split(/,/,q{");
2318                 sv_catpv(sv, ++s);
2319                 sv_catpv(sv,    "})");
2320             }
2321             s += strlen(s);
2322             my_setenv("PERL5DB", SvPV(sv, PL_na));
2323         }
2324         if (!PL_perldb) {
2325             PL_perldb = PERLDB_ALL;
2326             init_debugger();
2327         }
2328         return s;
2329     case 'D':
2330     {
2331 #ifdef DEBUGGING
2332         forbid_setid("-D");
2333         if (isALPHA(s[1])) {
2334             /* if adding extra options, remember to update DEBUG_MASK */
2335             static char debopts[] = "psltocPmfrxuLHXDSTRJ";
2336             char *d;
2337
2338             for (s++; *s && (d = strchr(debopts,*s)); s++)
2339                 PL_debug |= 1 << (d - debopts);
2340         }
2341         else {
2342             PL_debug = atoi(s+1);
2343             for (s++; isDIGIT(*s); s++) ;
2344         }
2345 #ifdef EBCDIC
2346         if (DEBUG_p_TEST_ && ckWARN_d(WARN_DEBUGGING))
2347             Perl_warner(aTHX_ packWARN(WARN_DEBUGGING),
2348                     "-Dp not implemented on this platform\n");
2349 #endif
2350         PL_debug |= DEBUG_TOP_FLAG;
2351 #else /* !DEBUGGING */
2352         if (ckWARN_d(WARN_DEBUGGING))
2353             Perl_warner(aTHX_ packWARN(WARN_DEBUGGING),
2354                    "Recompile perl with -DDEBUGGING to use -D switch\n");
2355         for (s++; isALNUM(*s); s++) ;
2356 #endif
2357         /*SUPPRESS 530*/
2358         return s;
2359     }
2360     case 'h':
2361         usage(PL_origargv[0]);
2362         PerlProc_exit(0);
2363     case 'i':
2364         if (PL_inplace)
2365             Safefree(PL_inplace);
2366         PL_inplace = savepv(s+1);
2367         /*SUPPRESS 530*/
2368         for (s = PL_inplace; *s && !isSPACE(*s); s++) ;
2369         if (*s) {
2370             *s++ = '\0';
2371             if (*s == '-')      /* Additional switches on #! line. */
2372                 s++;
2373         }
2374         return s;
2375     case 'I':   /* -I handled both here and in parse_body() */
2376         forbid_setid("-I");
2377         ++s;
2378         while (*s && isSPACE(*s))
2379             ++s;
2380         if (*s) {
2381             char *e, *p;
2382             p = s;
2383             /* ignore trailing spaces (possibly followed by other switches) */
2384             do {
2385                 for (e = p; *e && !isSPACE(*e); e++) ;
2386                 p = e;
2387                 while (isSPACE(*p))
2388                     p++;
2389             } while (*p && *p != '-');
2390             e = savepvn(s, e-s);
2391             incpush(e, TRUE, TRUE);
2392             Safefree(e);
2393             s = p;
2394             if (*s == '-')
2395                 s++;
2396         }
2397         else
2398             Perl_croak(aTHX_ "No directory specified for -I");
2399         return s;
2400     case 'l':
2401         PL_minus_l = TRUE;
2402         s++;
2403         if (PL_ors_sv) {
2404             SvREFCNT_dec(PL_ors_sv);
2405             PL_ors_sv = Nullsv;
2406         }
2407         if (isDIGIT(*s)) {
2408             I32 flags = 0;
2409             PL_ors_sv = newSVpvn("\n",1);
2410             numlen = 3 + (*s == '0');
2411             *SvPVX(PL_ors_sv) = (char)grok_oct(s, &numlen, &flags, NULL);
2412             s += numlen;
2413         }
2414         else {
2415             if (RsPARA(PL_rs)) {
2416                 PL_ors_sv = newSVpvn("\n\n",2);
2417             }
2418             else {
2419                 PL_ors_sv = newSVsv(PL_rs);
2420             }
2421         }
2422         return s;
2423     case 'M':
2424         forbid_setid("-M");     /* XXX ? */
2425         /* FALL THROUGH */
2426     case 'm':
2427         forbid_setid("-m");     /* XXX ? */
2428         if (*++s) {
2429             char *start;
2430             SV *sv;
2431             char *use = "use ";
2432             /* -M-foo == 'no foo'       */
2433             if (*s == '-') { use = "no "; ++s; }
2434             sv = newSVpv(use,0);
2435             start = s;
2436             /* We allow -M'Module qw(Foo Bar)'  */
2437             while(isALNUM(*s) || *s==':') ++s;
2438             if (*s != '=') {
2439                 sv_catpv(sv, start);
2440                 if (*(start-1) == 'm') {
2441                     if (*s != '\0')
2442                         Perl_croak(aTHX_ "Can't use '%c' after -mname", *s);
2443                     sv_catpv( sv, " ()");
2444                 }
2445             } else {
2446                 if (s == start)
2447                     Perl_croak(aTHX_ "Module name required with -%c option",
2448                                s[-1]);
2449                 sv_catpvn(sv, start, s-start);
2450                 sv_catpv(sv, " split(/,/,q{");
2451                 sv_catpv(sv, ++s);
2452                 sv_catpv(sv,    "})");
2453             }
2454             s += strlen(s);
2455             if (!PL_preambleav)
2456                 PL_preambleav = newAV();
2457             av_push(PL_preambleav, sv);
2458         }
2459         else
2460             Perl_croak(aTHX_ "No space allowed after -%c", *(s-1));
2461         return s;
2462     case 'n':
2463         PL_minus_n = TRUE;
2464         s++;
2465         return s;
2466     case 'p':
2467         PL_minus_p = TRUE;
2468         s++;
2469         return s;
2470     case 's':
2471         forbid_setid("-s");
2472         PL_doswitches = TRUE;
2473         s++;
2474         return s;
2475     case 't':
2476         if (!PL_tainting)
2477             Perl_croak(aTHX_ "Too late for \"-t\" option");
2478         s++;
2479         return s;
2480     case 'T':
2481         if (!PL_tainting)
2482             Perl_croak(aTHX_ "Too late for \"-T\" option");
2483         s++;
2484         return s;
2485     case 'u':
2486 #ifdef MACOS_TRADITIONAL
2487         Perl_croak(aTHX_ "Believe me, you don't want to use \"-u\" on a Macintosh");
2488 #endif
2489         PL_do_undump = TRUE;
2490         s++;
2491         return s;
2492     case 'U':
2493         PL_unsafe = TRUE;
2494         s++;
2495         return s;
2496     case 'v':
2497 #if !defined(DGUX)
2498         PerlIO_printf(PerlIO_stdout(),
2499                       Perl_form(aTHX_ "\nThis is perl, v%"VDf" built for %s",
2500                                 PL_patchlevel, ARCHNAME));
2501 #else /* DGUX */
2502 /* Adjust verbose output as in the perl that ships with the DG/UX OS from EMC */
2503         PerlIO_printf(PerlIO_stdout(),
2504                         Perl_form(aTHX_ "\nThis is perl, version %vd\n", PL_patchlevel));
2505         PerlIO_printf(PerlIO_stdout(),
2506                         Perl_form(aTHX_ "        built under %s at %s %s\n",
2507                                         OSNAME, __DATE__, __TIME__));
2508         PerlIO_printf(PerlIO_stdout(),
2509                         Perl_form(aTHX_ "        OS Specific Release: %s\n",
2510                                         OSVERS));
2511 #endif /* !DGUX */
2512
2513 #if defined(LOCAL_PATCH_COUNT)
2514         if (LOCAL_PATCH_COUNT > 0)
2515             PerlIO_printf(PerlIO_stdout(),
2516                           "\n(with %d registered patch%s, "
2517                           "see perl -V for more detail)",
2518                           (int)LOCAL_PATCH_COUNT,
2519                           (LOCAL_PATCH_COUNT!=1) ? "es" : "");
2520 #endif
2521
2522         PerlIO_printf(PerlIO_stdout(),
2523                       "\n\nCopyright 1987-2002, Larry Wall\n");
2524 #ifdef MACOS_TRADITIONAL
2525         PerlIO_printf(PerlIO_stdout(),
2526                       "\nMac OS port Copyright 1991-2002, Matthias Neeracher;\n"
2527                       "maintained by Chris Nandor\n");
2528 #endif
2529 #ifdef MSDOS
2530         PerlIO_printf(PerlIO_stdout(),
2531                       "\nMS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n");
2532 #endif
2533 #ifdef DJGPP
2534         PerlIO_printf(PerlIO_stdout(),
2535                       "djgpp v2 port (jpl5003c) by Hirofumi Watanabe, 1996\n"
2536                       "djgpp v2 port (perl5004+) by Laszlo Molnar, 1997-1999\n");
2537 #endif
2538 #ifdef OS2
2539         PerlIO_printf(PerlIO_stdout(),
2540                       "\n\nOS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n"
2541                       "Version 5 port Copyright (c) 1994-2002, Andreas Kaiser, Ilya Zakharevich\n");
2542 #endif
2543 #ifdef atarist
2544         PerlIO_printf(PerlIO_stdout(),
2545                       "atariST series port, ++jrb  bammi@cadence.com\n");
2546 #endif
2547 #ifdef __BEOS__
2548         PerlIO_printf(PerlIO_stdout(),
2549                       "BeOS port Copyright Tom Spindler, 1997-1999\n");
2550 #endif
2551 #ifdef MPE
2552         PerlIO_printf(PerlIO_stdout(),
2553                       "MPE/iX port Copyright by Mark Klein and Mark Bixby, 1996-2002\n");
2554 #endif
2555 #ifdef OEMVS
2556         PerlIO_printf(PerlIO_stdout(),
2557                       "MVS (OS390) port by Mortice Kern Systems, 1997-1999\n");
2558 #endif
2559 #ifdef __VOS__
2560         PerlIO_printf(PerlIO_stdout(),
2561                       "Stratus VOS port by Paul.Green@stratus.com, 1997-2002\n");
2562 #endif
2563 #ifdef __OPEN_VM
2564         PerlIO_printf(PerlIO_stdout(),
2565                       "VM/ESA port by Neale Ferguson, 1998-1999\n");
2566 #endif
2567 #ifdef POSIX_BC
2568         PerlIO_printf(PerlIO_stdout(),
2569                       "BS2000 (POSIX) port by Start Amadeus GmbH, 1998-1999\n");
2570 #endif
2571 #ifdef __MINT__
2572         PerlIO_printf(PerlIO_stdout(),
2573                       "MiNT port by Guido Flohr, 1997-1999\n");
2574 #endif
2575 #ifdef EPOC
2576         PerlIO_printf(PerlIO_stdout(),
2577                       "EPOC port by Olaf Flebbe, 1999-2002\n");
2578 #endif
2579 #ifdef UNDER_CE
2580         printf("WINCE port by Rainer Keuchel, 2001-2002\n");
2581         printf("Built on " __DATE__ " " __TIME__ "\n\n");
2582         wce_hitreturn();
2583 #endif
2584 #ifdef BINARY_BUILD_NOTICE
2585         BINARY_BUILD_NOTICE;
2586 #endif
2587         PerlIO_printf(PerlIO_stdout(),
2588                       "\n\
2589 Perl may be copied only under the terms of either the Artistic License or the\n\
2590 GNU General Public License, which may be found in the Perl 5 source kit.\n\n\
2591 Complete documentation for Perl, including FAQ lists, should be found on\n\
2592 this system using `man perl' or `perldoc perl'.  If you have access to the\n\
2593 Internet, point your browser at http://www.perl.com/, the Perl Home Page.\n\n");
2594         PerlProc_exit(0);
2595     case 'w':
2596         if (! (PL_dowarn & G_WARN_ALL_MASK))
2597             PL_dowarn |= G_WARN_ON;
2598         s++;
2599         return s;
2600     case 'W':
2601         PL_dowarn = G_WARN_ALL_ON|G_WARN_ON;
2602         if (!specialWARN(PL_compiling.cop_warnings))
2603             SvREFCNT_dec(PL_compiling.cop_warnings);
2604         PL_compiling.cop_warnings = pWARN_ALL ;
2605         s++;
2606         return s;
2607     case 'X':
2608         PL_dowarn = G_WARN_ALL_OFF;
2609         if (!specialWARN(PL_compiling.cop_warnings))
2610             SvREFCNT_dec(PL_compiling.cop_warnings);
2611         PL_compiling.cop_warnings = pWARN_NONE ;
2612         s++;
2613         return s;
2614     case '*':
2615     case ' ':
2616         if (s[1] == '-')        /* Additional switches on #! line. */
2617             return s+2;
2618         break;
2619     case '-':
2620     case 0:
2621 #if defined(WIN32) || !defined(PERL_STRICT_CR)
2622     case '\r':
2623 #endif
2624     case '\n':
2625     case '\t':
2626         break;
2627 #ifdef ALTERNATE_SHEBANG
2628     case 'S':                   /* OS/2 needs -S on "extproc" line. */
2629         break;
2630 #endif
2631     case 'P':
2632         if (PL_preprocess)
2633             return s+1;
2634         /* FALL THROUGH */
2635     default:
2636         Perl_croak(aTHX_ "Can't emulate -%.1s on #! line",s);
2637     }
2638     return Nullch;
2639 }
2640
2641 /* compliments of Tom Christiansen */
2642
2643 /* unexec() can be found in the Gnu emacs distribution */
2644 /* Known to work with -DUNEXEC and using unexelf.c from GNU emacs-20.2 */
2645
2646 void
2647 Perl_my_unexec(pTHX)
2648 {
2649 #ifdef UNEXEC
2650     SV*    prog;
2651     SV*    file;
2652     int    status = 1;
2653     extern int etext;
2654
2655     prog = newSVpv(BIN_EXP, 0);
2656     sv_catpv(prog, "/perl");
2657     file = newSVpv(PL_origfilename, 0);
2658     sv_catpv(file, ".perldump");
2659
2660     unexec(SvPVX(file), SvPVX(prog), &etext, sbrk(0), 0);
2661     /* unexec prints msg to stderr in case of failure */
2662     PerlProc_exit(status);
2663 #else
2664 #  ifdef VMS
2665 #    include <lib$routines.h>
2666      lib$signal(SS$_DEBUG);  /* ssdef.h #included from vmsish.h */
2667 #  else
2668     ABORT();            /* for use with undump */
2669 #  endif
2670 #endif
2671 }
2672
2673 /* initialize curinterp */
2674 STATIC void
2675 S_init_interp(pTHX)
2676 {
2677
2678 #ifdef MULTIPLICITY
2679 #  define PERLVAR(var,type)
2680 #  define PERLVARA(var,n,type)
2681 #  if defined(PERL_IMPLICIT_CONTEXT)
2682 #    if defined(USE_5005THREADS)
2683 #      define PERLVARI(var,type,init)           PERL_GET_INTERP->var = init;
2684 #      define PERLVARIC(var,type,init)  PERL_GET_INTERP->var = init;
2685 #    else /* !USE_5005THREADS */
2686 #      define PERLVARI(var,type,init)           aTHX->var = init;
2687 #      define PERLVARIC(var,type,init)  aTHX->var = init;
2688 #    endif /* USE_5005THREADS */
2689 #  else
2690 #    define PERLVARI(var,type,init)     PERL_GET_INTERP->var = init;
2691 #    define PERLVARIC(var,type,init)    PERL_GET_INTERP->var = init;
2692 #  endif
2693 #  include "intrpvar.h"
2694 #  ifndef USE_5005THREADS
2695 #    include "thrdvar.h"
2696 #  endif
2697 #  undef PERLVAR
2698 #  undef PERLVARA
2699 #  undef PERLVARI
2700 #  undef PERLVARIC
2701 #else
2702 #  define PERLVAR(var,type)
2703 #  define PERLVARA(var,n,type)
2704 #  define PERLVARI(var,type,init)       PL_##var = init;
2705 #  define PERLVARIC(var,type,init)      PL_##var = init;
2706 #  include "intrpvar.h"
2707 #  ifndef USE_5005THREADS
2708 #    include "thrdvar.h"
2709 #  endif
2710 #  undef PERLVAR
2711 #  undef PERLVARA
2712 #  undef PERLVARI
2713 #  undef PERLVARIC
2714 #endif
2715
2716 }
2717
2718 STATIC void
2719 S_init_main_stash(pTHX)
2720 {
2721     GV *gv;
2722
2723     PL_curstash = PL_defstash = newHV();
2724     PL_curstname = newSVpvn("main",4);
2725     gv = gv_fetchpv("main::",TRUE, SVt_PVHV);
2726     SvREFCNT_dec(GvHV(gv));
2727     GvHV(gv) = (HV*)SvREFCNT_inc(PL_defstash);
2728     SvREADONLY_on(gv);
2729     HvNAME(PL_defstash) = savepv("main");
2730     PL_incgv = gv_HVadd(gv_AVadd(gv_fetchpv("INC",TRUE, SVt_PVAV)));
2731     GvMULTI_on(PL_incgv);
2732     PL_hintgv = gv_fetchpv("\010",TRUE, SVt_PV); /* ^H */
2733     GvMULTI_on(PL_hintgv);
2734     PL_defgv = gv_fetchpv("_",TRUE, SVt_PVAV);
2735     PL_errgv = gv_HVadd(gv_fetchpv("@", TRUE, SVt_PV));
2736     GvMULTI_on(PL_errgv);
2737     PL_replgv = gv_fetchpv("\022", TRUE, SVt_PV); /* ^R */
2738     GvMULTI_on(PL_replgv);
2739     (void)Perl_form(aTHX_ "%240s","");  /* Preallocate temp - for immediate signals. */
2740     sv_grow(ERRSV, 240);        /* Preallocate - for immediate signals. */
2741     sv_setpvn(ERRSV, "", 0);
2742     PL_curstash = PL_defstash;
2743     CopSTASH_set(&PL_compiling, PL_defstash);
2744     PL_debstash = GvHV(gv_fetchpv("DB::", GV_ADDMULTI, SVt_PVHV));
2745     PL_globalstash = GvHV(gv_fetchpv("CORE::GLOBAL::", GV_ADDMULTI, SVt_PVHV));
2746     PL_nullstash = GvHV(gv_fetchpv("<none>::", GV_ADDMULTI, SVt_PVHV));
2747     /* We must init $/ before switches are processed. */
2748     sv_setpvn(get_sv("/", TRUE), "\n", 1);
2749 }
2750
2751 STATIC void
2752 S_open_script(pTHX_ char *scriptname, bool dosearch, SV *sv, int *fdscript)
2753 {
2754     char *quote;
2755     char *code;
2756     char *cpp_discard_flag;
2757     char *perl;
2758
2759     *fdscript = -1;
2760
2761     if (PL_e_script) {
2762         PL_origfilename = savepv("-e");
2763     }
2764     else {
2765         /* if find_script() returns, it returns a malloc()-ed value */
2766         PL_origfilename = scriptname = find_script(scriptname, dosearch, NULL, 1);
2767
2768         if (strnEQ(scriptname, "/dev/fd/", 8) && isDIGIT(scriptname[8]) ) {
2769             char *s = scriptname + 8;
2770             *fdscript = atoi(s);
2771             while (isDIGIT(*s))
2772                 s++;
2773             if (*s) {
2774                 scriptname = savepv(s + 1);
2775                 Safefree(PL_origfilename);
2776                 PL_origfilename = scriptname;
2777             }
2778         }
2779     }
2780
2781     CopFILE_free(PL_curcop);
2782     CopFILE_set(PL_curcop, PL_origfilename);
2783     if (strEQ(PL_origfilename,"-"))
2784         scriptname = "";
2785     if (*fdscript >= 0) {
2786         PL_rsfp = PerlIO_fdopen(*fdscript,PERL_SCRIPT_MODE);
2787 #       if defined(HAS_FCNTL) && defined(F_SETFD)
2788             if (PL_rsfp)
2789                 /* ensure close-on-exec */
2790                 fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,1);
2791 #       endif
2792     }
2793     else if (PL_preprocess) {
2794         char *cpp_cfg = CPPSTDIN;
2795         SV *cpp = newSVpvn("",0);
2796         SV *cmd = NEWSV(0,0);
2797
2798         if (strEQ(cpp_cfg, "cppstdin"))
2799             Perl_sv_catpvf(aTHX_ cpp, "%s/", BIN_EXP);
2800         sv_catpv(cpp, cpp_cfg);
2801
2802 #       ifndef VMS
2803             sv_catpvn(sv, "-I", 2);
2804             sv_catpv(sv,PRIVLIB_EXP);
2805 #       endif
2806
2807         DEBUG_P(PerlIO_printf(Perl_debug_log,
2808                               "PL_preprocess: scriptname=\"%s\", cpp=\"%s\", sv=\"%s\", CPPMINUS=\"%s\"\n",
2809                               scriptname, SvPVX (cpp), SvPVX (sv), CPPMINUS));
2810
2811 #       if defined(MSDOS) || defined(WIN32) || defined(VMS)
2812             quote = "\"";
2813 #       else
2814             quote = "'";
2815 #       endif
2816
2817 #       ifdef VMS
2818             cpp_discard_flag = "";
2819 #       else
2820             cpp_discard_flag = "-C";
2821 #       endif
2822
2823 #       ifdef OS2
2824             perl = os2_execname(aTHX);
2825 #       else
2826             perl = PL_origargv[0];
2827 #       endif
2828
2829
2830         /* This strips off Perl comments which might interfere with
2831            the C pre-processor, including #!.  #line directives are
2832            deliberately stripped to avoid confusion with Perl's version
2833            of #line.  FWP played some golf with it so it will fit
2834            into VMS's 255 character buffer.
2835         */
2836         if( PL_doextract )
2837             code = "(1../^#!.*perl/i)|/^\\s*#(?!\\s*((ifn?|un)def|(el|end)?if|define|include|else|error|pragma)\\b)/||!($|=1)||print";
2838         else
2839             code = "/^\\s*#(?!\\s*((ifn?|un)def|(el|end)?if|define|include|else|error|pragma)\\b)/||!($|=1)||print";
2840
2841         Perl_sv_setpvf(aTHX_ cmd, "\
2842 %s -ne%s%s%s %s | %"SVf" %s %"SVf" %s",
2843                        perl, quote, code, quote, scriptname, cpp,
2844                        cpp_discard_flag, sv, CPPMINUS);
2845
2846         PL_doextract = FALSE;
2847 #       ifdef IAMSUID                   /* actually, this is caught earlier */
2848             if (PL_euid != PL_uid && !PL_euid) {  /* if running suidperl */
2849 #               ifdef HAS_SETEUID
2850                     (void)seteuid(PL_uid);        /* musn't stay setuid root */
2851 #               else
2852 #               ifdef HAS_SETREUID
2853                     (void)setreuid((Uid_t)-1, PL_uid);
2854 #               else
2855 #               ifdef HAS_SETRESUID
2856                     (void)setresuid((Uid_t)-1, PL_uid, (Uid_t)-1);
2857 #               else
2858                     PerlProc_setuid(PL_uid);
2859 #               endif
2860 #               endif
2861 #               endif
2862             if (PerlProc_geteuid() != PL_uid)
2863                 Perl_croak(aTHX_ "Can't do seteuid!\n");
2864         }
2865 #       endif /* IAMSUID */
2866
2867         DEBUG_P(PerlIO_printf(Perl_debug_log,
2868                               "PL_preprocess: cmd=\"%s\"\n",
2869                               SvPVX(cmd)));
2870
2871         PL_rsfp = PerlProc_popen(SvPVX(cmd), "r");
2872         SvREFCNT_dec(cmd);
2873         SvREFCNT_dec(cpp);
2874     }
2875     else if (!*scriptname) {
2876         forbid_setid("program input from stdin");
2877         PL_rsfp = PerlIO_stdin();
2878     }
2879     else {
2880         PL_rsfp = PerlIO_open(scriptname,PERL_SCRIPT_MODE);
2881 #       if defined(HAS_FCNTL) && defined(F_SETFD)
2882             if (PL_rsfp)
2883                 /* ensure close-on-exec */
2884                 fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,1);
2885 #       endif
2886     }
2887     if (!PL_rsfp) {
2888 #       ifdef DOSUID
2889 #       ifndef IAMSUID  /* in case script is not readable before setuid */
2890             if (PL_euid &&
2891                 PerlLIO_stat(CopFILE(PL_curcop),&PL_statbuf) >= 0 &&
2892                 PL_statbuf.st_mode & (S_ISUID|S_ISGID))
2893             {
2894                 /* try again */
2895                 PerlProc_execv(Perl_form(aTHX_ "%s/sperl"PERL_FS_VER_FMT,
2896                                          BIN_EXP, (int)PERL_REVISION,
2897                                          (int)PERL_VERSION,
2898                                          (int)PERL_SUBVERSION), PL_origargv);
2899                 Perl_croak(aTHX_ "Can't do setuid\n");
2900             }
2901 #       endif
2902 #       endif
2903 #       ifdef IAMSUID
2904             errno = EPERM;
2905             Perl_croak(aTHX_ "Can't open perl script: %s\n",
2906                        Strerror(errno));
2907 #       else
2908             Perl_croak(aTHX_ "Can't open perl script \"%s\": %s\n",
2909                        CopFILE(PL_curcop), Strerror(errno));
2910 #       endif
2911     }
2912 }
2913
2914 /* Mention
2915  * I_SYSSTATVFS HAS_FSTATVFS
2916  * I_SYSMOUNT
2917  * I_STATFS     HAS_FSTATFS     HAS_GETFSSTAT
2918  * I_MNTENT     HAS_GETMNTENT   HAS_HASMNTOPT
2919  * here so that metaconfig picks them up. */
2920
2921 #ifdef IAMSUID
2922 STATIC int
2923 S_fd_on_nosuid_fs(pTHX_ int fd)
2924 {
2925     int check_okay = 0; /* able to do all the required sys/libcalls */
2926     int on_nosuid  = 0; /* the fd is on a nosuid fs */
2927 /*
2928  * Preferred order: fstatvfs(), fstatfs(), ustat()+getmnt(), getmntent().
2929  * fstatvfs() is UNIX98.
2930  * fstatfs() is 4.3 BSD.
2931  * ustat()+getmnt() is pre-4.3 BSD.
2932  * getmntent() is O(number-of-mounted-filesystems) and can hang on
2933  * an irrelevant filesystem while trying to reach the right one.
2934  */
2935
2936 #undef FD_ON_NOSUID_CHECK_OKAY  /* found the syscalls to do the check? */
2937
2938 #   if !defined(FD_ON_NOSUID_CHECK_OKAY) && \
2939         defined(HAS_FSTATVFS)
2940 #   define FD_ON_NOSUID_CHECK_OKAY
2941     struct statvfs stfs;
2942
2943     check_okay = fstatvfs(fd, &stfs) == 0;
2944     on_nosuid  = check_okay && (stfs.f_flag  & ST_NOSUID);
2945 #   endif /* fstatvfs */
2946
2947 #   if !defined(FD_ON_NOSUID_CHECK_OKAY) && \
2948         defined(PERL_MOUNT_NOSUID)      && \
2949         defined(HAS_FSTATFS)            && \
2950         defined(HAS_STRUCT_STATFS)      && \
2951         defined(HAS_STRUCT_STATFS_F_FLAGS)
2952 #   define FD_ON_NOSUID_CHECK_OKAY
2953     struct statfs  stfs;
2954
2955     check_okay = fstatfs(fd, &stfs)  == 0;
2956     on_nosuid  = check_okay && (stfs.f_flags & PERL_MOUNT_NOSUID);
2957 #   endif /* fstatfs */
2958
2959 #   if !defined(FD_ON_NOSUID_CHECK_OKAY) && \
2960         defined(PERL_MOUNT_NOSUID)      && \
2961         defined(HAS_FSTAT)              && \
2962         defined(HAS_USTAT)              && \
2963         defined(HAS_GETMNT)             && \
2964         defined(HAS_STRUCT_FS_DATA)     && \
2965         defined(NOSTAT_ONE)
2966 #   define FD_ON_NOSUID_CHECK_OKAY
2967     Stat_t fdst;
2968
2969     if (fstat(fd, &fdst) == 0) {
2970         struct ustat us;
2971         if (ustat(fdst.st_dev, &us) == 0) {
2972             struct fs_data fsd;
2973             /* NOSTAT_ONE here because we're not examining fields which
2974              * vary between that case and STAT_ONE. */
2975             if (getmnt((int*)0, &fsd, (int)0, NOSTAT_ONE, us.f_fname) == 0) {
2976                 size_t cmplen = sizeof(us.f_fname);
2977                 if (sizeof(fsd.fd_req.path) < cmplen)
2978                     cmplen = sizeof(fsd.fd_req.path);
2979                 if (strnEQ(fsd.fd_req.path, us.f_fname, cmplen) &&
2980                     fdst.st_dev == fsd.fd_req.dev) {
2981                         check_okay = 1;
2982                         on_nosuid = fsd.fd_req.flags & PERL_MOUNT_NOSUID;
2983                     }
2984                 }
2985             }
2986         }
2987     }
2988 #   endif /* fstat+ustat+getmnt */
2989
2990 #   if !defined(FD_ON_NOSUID_CHECK_OKAY) && \
2991         defined(HAS_GETMNTENT)          && \
2992         defined(HAS_HASMNTOPT)          && \
2993         defined(MNTOPT_NOSUID)
2994 #   define FD_ON_NOSUID_CHECK_OKAY
2995     FILE                *mtab = fopen("/etc/mtab", "r");
2996     struct mntent       *entry;
2997     Stat_t              stb, fsb;
2998
2999     if (mtab && (fstat(fd, &stb) == 0)) {
3000         while (entry = getmntent(mtab)) {
3001             if (stat(entry->mnt_dir, &fsb) == 0
3002                 && fsb.st_dev == stb.st_dev)
3003             {
3004                 /* found the filesystem */
3005                 check_okay = 1;
3006                 if (hasmntopt(entry, MNTOPT_NOSUID))
3007                     on_nosuid = 1;
3008                 break;
3009             } /* A single fs may well fail its stat(). */
3010         }
3011     }
3012     if (mtab)
3013         fclose(mtab);
3014 #   endif /* getmntent+hasmntopt */
3015
3016     if (!check_okay)
3017         Perl_croak(aTHX_ "Can't check filesystem of script \"%s\" for nosuid", PL_origfilename);
3018     return on_nosuid;
3019 }
3020 #endif /* IAMSUID */
3021
3022 STATIC void
3023 S_validate_suid(pTHX_ char *validarg, char *scriptname, int fdscript)
3024 {
3025 #ifdef IAMSUID
3026     int which;
3027 #endif
3028
3029     /* do we need to emulate setuid on scripts? */
3030
3031     /* This code is for those BSD systems that have setuid #! scripts disabled
3032      * in the kernel because of a security problem.  Merely defining DOSUID
3033      * in perl will not fix that problem, but if you have disabled setuid
3034      * scripts in the kernel, this will attempt to emulate setuid and setgid
3035      * on scripts that have those now-otherwise-useless bits set.  The setuid
3036      * root version must be called suidperl or sperlN.NNN.  If regular perl
3037      * discovers that it has opened a setuid script, it calls suidperl with
3038      * the same argv that it had.  If suidperl finds that the script it has
3039      * just opened is NOT setuid root, it sets the effective uid back to the
3040      * uid.  We don't just make perl setuid root because that loses the
3041      * effective uid we had before invoking perl, if it was different from the
3042      * uid.
3043      *
3044      * DOSUID must be defined in both perl and suidperl, and IAMSUID must
3045      * be defined in suidperl only.  suidperl must be setuid root.  The
3046      * Configure script will set this up for you if you want it.
3047      */
3048
3049 #ifdef DOSUID
3050     char *s, *s2;
3051
3052     if (PerlLIO_fstat(PerlIO_fileno(PL_rsfp),&PL_statbuf) < 0)  /* normal stat is insecure */
3053         Perl_croak(aTHX_ "Can't stat script \"%s\"",PL_origfilename);
3054     if (fdscript < 0 && PL_statbuf.st_mode & (S_ISUID|S_ISGID)) {
3055         I32 len;
3056         STRLEN n_a;
3057
3058 #ifdef IAMSUID
3059 #ifndef HAS_SETREUID
3060         /* On this access check to make sure the directories are readable,
3061          * there is actually a small window that the user could use to make
3062          * filename point to an accessible directory.  So there is a faint
3063          * chance that someone could execute a setuid script down in a
3064          * non-accessible directory.  I don't know what to do about that.
3065          * But I don't think it's too important.  The manual lies when
3066          * it says access() is useful in setuid programs.
3067          */
3068         if (PerlLIO_access(CopFILE(PL_curcop),1)) /*double check*/
3069             Perl_croak(aTHX_ "Permission denied");
3070 #else
3071         /* If we can swap euid and uid, then we can determine access rights
3072          * with a simple stat of the file, and then compare device and
3073          * inode to make sure we did stat() on the same file we opened.
3074          * Then we just have to make sure he or she can execute it.
3075          */
3076         {
3077             Stat_t tmpstatbuf;
3078
3079             if (
3080 #ifdef HAS_SETREUID
3081                 setreuid(PL_euid,PL_uid) < 0
3082 #else
3083 # if HAS_SETRESUID
3084                 setresuid(PL_euid,PL_uid,(Uid_t)-1) < 0
3085 # endif
3086 #endif
3087                 || PerlProc_getuid() != PL_euid || PerlProc_geteuid() != PL_uid)
3088                 Perl_croak(aTHX_ "Can't swap uid and euid");    /* really paranoid */
3089             if (PerlLIO_stat(CopFILE(PL_curcop),&tmpstatbuf) < 0)
3090                 Perl_croak(aTHX_ "Permission denied");  /* testing full pathname here */
3091 #if defined(IAMSUID) && !defined(NO_NOSUID_CHECK)
3092             if (fd_on_nosuid_fs(PerlIO_fileno(PL_rsfp)))
3093                 Perl_croak(aTHX_ "Permission denied");
3094 #endif
3095             if (tmpstatbuf.st_dev != PL_statbuf.st_dev ||
3096                 tmpstatbuf.st_ino != PL_statbuf.st_ino) {
3097                 (void)PerlIO_close(PL_rsfp);
3098                 Perl_croak(aTHX_ "Permission denied\n");
3099             }
3100             if (
3101 #ifdef HAS_SETREUID
3102               setreuid(PL_uid,PL_euid) < 0
3103 #else
3104 # if defined(HAS_SETRESUID)
3105               setresuid(PL_uid,PL_euid,(Uid_t)-1) < 0
3106 # endif
3107 #endif
3108               || PerlProc_getuid() != PL_uid || PerlProc_geteuid() != PL_euid)
3109                 Perl_croak(aTHX_ "Can't reswap uid and euid");
3110             if (!cando(S_IXUSR,FALSE,&PL_statbuf))              /* can real uid exec? */
3111                 Perl_croak(aTHX_ "Permission denied\n");
3112         }
3113 #endif /* HAS_SETREUID */
3114 #endif /* IAMSUID */
3115
3116         if (!S_ISREG(PL_statbuf.st_mode))
3117             Perl_croak(aTHX_ "Permission denied");
3118         if (PL_statbuf.st_mode & S_IWOTH)
3119             Perl_croak(aTHX_ "Setuid/gid script is writable by world");
3120         PL_doswitches = FALSE;          /* -s is insecure in suid */
3121         CopLINE_inc(PL_curcop);
3122         if (sv_gets(PL_linestr, PL_rsfp, 0) == Nullch ||
3123           strnNE(SvPV(PL_linestr,n_a),"#!",2) ) /* required even on Sys V */
3124             Perl_croak(aTHX_ "No #! line");
3125         s = SvPV(PL_linestr,n_a)+2;
3126         if (*s == ' ') s++;
3127         while (!isSPACE(*s)) s++;
3128         for (s2 = s;  (s2 > SvPV(PL_linestr,n_a)+2 &&
3129                        (isDIGIT(s2[-1]) || strchr("._-", s2[-1])));  s2--) ;
3130         if (strnNE(s2-4,"perl",4) && strnNE(s-9,"perl",4))  /* sanity check */
3131             Perl_croak(aTHX_ "Not a perl script");
3132         while (*s == ' ' || *s == '\t') s++;
3133         /*
3134          * #! arg must be what we saw above.  They can invoke it by
3135          * mentioning suidperl explicitly, but they may not add any strange
3136          * arguments beyond what #! says if they do invoke suidperl that way.
3137          */
3138         len = strlen(validarg);
3139         if (strEQ(validarg," PHOOEY ") ||
3140             strnNE(s,validarg,len) || !isSPACE(s[len]))
3141             Perl_croak(aTHX_ "Args must match #! line");
3142
3143 #ifndef IAMSUID
3144         if (PL_euid != PL_uid && (PL_statbuf.st_mode & S_ISUID) &&
3145             PL_euid == PL_statbuf.st_uid)
3146             if (!PL_do_undump)
3147                 Perl_croak(aTHX_ "YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
3148 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
3149 #endif /* IAMSUID */
3150
3151         if (PL_euid) {  /* oops, we're not the setuid root perl */
3152             (void)PerlIO_close(PL_rsfp);
3153 #ifndef IAMSUID
3154             /* try again */
3155             PerlProc_execv(Perl_form(aTHX_ "%s/sperl"PERL_FS_VER_FMT, BIN_EXP,
3156                                      (int)PERL_REVISION, (int)PERL_VERSION,
3157                                      (int)PERL_SUBVERSION), PL_origargv);
3158 #endif
3159             Perl_croak(aTHX_ "Can't do setuid\n");
3160         }
3161
3162         if (PL_statbuf.st_mode & S_ISGID && PL_statbuf.st_gid != PL_egid) {
3163 #ifdef HAS_SETEGID
3164             (void)setegid(PL_statbuf.st_gid);
3165 #else
3166 #ifdef HAS_SETREGID
3167            (void)setregid((Gid_t)-1,PL_statbuf.st_gid);
3168 #else
3169 #ifdef HAS_SETRESGID
3170            (void)setresgid((Gid_t)-1,PL_statbuf.st_gid,(Gid_t)-1);
3171 #else
3172             PerlProc_setgid(PL_statbuf.st_gid);
3173 #endif
3174 #endif
3175 #endif
3176             if (PerlProc_getegid() != PL_statbuf.st_gid)
3177                 Perl_croak(aTHX_ "Can't do setegid!\n");
3178         }
3179         if (PL_statbuf.st_mode & S_ISUID) {
3180             if (PL_statbuf.st_uid != PL_euid)
3181 #ifdef HAS_SETEUID
3182                 (void)seteuid(PL_statbuf.st_uid);       /* all that for this */
3183 #else
3184 #ifdef HAS_SETREUID
3185                 (void)setreuid((Uid_t)-1,PL_statbuf.st_uid);
3186 #else
3187 #ifdef HAS_SETRESUID
3188                 (void)setresuid((Uid_t)-1,PL_statbuf.st_uid,(Uid_t)-1);
3189 #else
3190                 PerlProc_setuid(PL_statbuf.st_uid);
3191 #endif
3192 #endif
3193 #endif
3194             if (PerlProc_geteuid() != PL_statbuf.st_uid)
3195                 Perl_croak(aTHX_ "Can't do seteuid!\n");
3196         }
3197         else if (PL_uid) {                      /* oops, mustn't run as root */
3198 #ifdef HAS_SETEUID
3199           (void)seteuid((Uid_t)PL_uid);
3200 #else
3201 #ifdef HAS_SETREUID
3202           (void)setreuid((Uid_t)-1,(Uid_t)PL_uid);
3203 #else
3204 #ifdef HAS_SETRESUID
3205           (void)setresuid((Uid_t)-1,(Uid_t)PL_uid,(Uid_t)-1);
3206 #else
3207           PerlProc_setuid((Uid_t)PL_uid);
3208 #endif
3209 #endif
3210 #endif
3211             if (PerlProc_geteuid() != PL_uid)
3212                 Perl_croak(aTHX_ "Can't do seteuid!\n");
3213         }
3214         init_ids();
3215         if (!cando(S_IXUSR,TRUE,&PL_statbuf))
3216             Perl_croak(aTHX_ "Permission denied\n");    /* they can't do this */
3217     }
3218 #ifdef IAMSUID
3219     else if (PL_preprocess)
3220         Perl_croak(aTHX_ "-P not allowed for setuid/setgid script\n");
3221     else if (fdscript >= 0)
3222         Perl_croak(aTHX_ "fd script not allowed in suidperl\n");
3223     else
3224         Perl_croak(aTHX_ "Script is not setuid/setgid in suidperl\n");
3225
3226     /* We absolutely must clear out any saved ids here, so we */
3227     /* exec the real perl, substituting fd script for scriptname. */
3228     /* (We pass script name as "subdir" of fd, which perl will grok.) */
3229     PerlIO_rewind(PL_rsfp);
3230     PerlLIO_lseek(PerlIO_fileno(PL_rsfp),(Off_t)0,0);  /* just in case rewind didn't */
3231     for (which = 1; PL_origargv[which] && PL_origargv[which] != scriptname; which++) ;
3232     if (!PL_origargv[which])
3233         Perl_croak(aTHX_ "Permission denied");
3234     PL_origargv[which] = savepv(Perl_form(aTHX_ "/dev/fd/%d/%s",
3235                                   PerlIO_fileno(PL_rsfp), PL_origargv[which]));
3236 #if defined(HAS_FCNTL) && defined(F_SETFD)
3237     fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,0);    /* ensure no close-on-exec */
3238 #endif
3239     PerlProc_execv(Perl_form(aTHX_ "%s/perl"PERL_FS_VER_FMT, BIN_EXP,
3240                              (int)PERL_REVISION, (int)PERL_VERSION,
3241                              (int)PERL_SUBVERSION), PL_origargv);/* try again */
3242     Perl_croak(aTHX_ "Can't do setuid\n");
3243 #endif /* IAMSUID */
3244 #else /* !DOSUID */
3245     if (PL_euid != PL_uid || PL_egid != PL_gid) {       /* (suidperl doesn't exist, in fact) */
3246 #ifndef SETUID_SCRIPTS_ARE_SECURE_NOW
3247         PerlLIO_fstat(PerlIO_fileno(PL_rsfp),&PL_statbuf);      /* may be either wrapped or real suid */
3248         if ((PL_euid != PL_uid && PL_euid == PL_statbuf.st_uid && PL_statbuf.st_mode & S_ISUID)
3249             ||
3250             (PL_egid != PL_gid && PL_egid == PL_statbuf.st_gid && PL_statbuf.st_mode & S_ISGID)
3251            )
3252             if (!PL_do_undump)
3253                 Perl_croak(aTHX_ "YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
3254 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
3255 #endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
3256         /* not set-id, must be wrapped */
3257     }
3258 #endif /* DOSUID */
3259 }
3260
3261 STATIC void
3262 S_find_beginning(pTHX)
3263 {
3264     register char *s, *s2;
3265
3266     /* skip forward in input to the real script? */
3267
3268     forbid_setid("-x");
3269 #ifdef MACOS_TRADITIONAL
3270     /* Since the Mac OS does not honor #! arguments for us, we do it ourselves */
3271
3272     while (PL_doextract || gMacPerl_AlwaysExtract) {
3273         if ((s = sv_gets(PL_linestr, PL_rsfp, 0)) == Nullch) {
3274             if (!gMacPerl_AlwaysExtract)
3275                 Perl_croak(aTHX_ "No Perl script found in input\n");
3276
3277             if (PL_doextract)                   /* require explicit override ? */
3278                 if (!OverrideExtract(PL_origfilename))
3279                     Perl_croak(aTHX_ "User aborted script\n");
3280                 else
3281                     PL_doextract = FALSE;
3282
3283             /* Pater peccavi, file does not have #! */
3284             PerlIO_rewind(PL_rsfp);
3285
3286             break;
3287         }
3288 #else
3289     while (PL_doextract) {
3290         if ((s = sv_gets(PL_linestr, PL_rsfp, 0)) == Nullch)
3291             Perl_croak(aTHX_ "No Perl script found in input\n");
3292 #endif
3293         s2 = s;
3294         if (*s == '#' && s[1] == '!' && ((s = instr(s,"perl")) || (s = instr(s2,"PERL")))) {
3295             PerlIO_ungetc(PL_rsfp, '\n');               /* to keep line count right */
3296             PL_doextract = FALSE;
3297             while (*s && !(isSPACE (*s) || *s == '#')) s++;
3298             s2 = s;
3299             while (*s == ' ' || *s == '\t') s++;
3300             if (*s++ == '-') {
3301                 while (isDIGIT(s2[-1]) || strchr("-._", s2[-1])) s2--;
3302                 if (strnEQ(s2-4,"perl",4))
3303                     /*SUPPRESS 530*/
3304                     while ((s = moreswitches(s)))
3305                         ;
3306             }
3307 #ifdef MACOS_TRADITIONAL
3308             break;
3309 #endif
3310         }
3311     }
3312 }
3313
3314
3315 STATIC void
3316 S_init_ids(pTHX)
3317 {
3318     PL_uid = PerlProc_getuid();
3319     PL_euid = PerlProc_geteuid();
3320     PL_gid = PerlProc_getgid();
3321     PL_egid = PerlProc_getegid();
3322 #ifdef VMS
3323     PL_uid |= PL_gid << 16;
3324     PL_euid |= PL_egid << 16;
3325 #endif
3326     PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
3327 }
3328
3329 STATIC void
3330 S_forbid_setid(pTHX_ char *s)
3331 {
3332     if (PL_euid != PL_uid)
3333         Perl_croak(aTHX_ "No %s allowed while running setuid", s);
3334     if (PL_egid != PL_gid)
3335         Perl_croak(aTHX_ "No %s allowed while running setgid", s);
3336 }
3337
3338 void
3339 Perl_init_debugger(pTHX)
3340 {
3341     HV *ostash = PL_curstash;
3342
3343     PL_curstash = PL_debstash;
3344     PL_dbargs = GvAV(gv_AVadd((gv_fetchpv("args", GV_ADDMULTI, SVt_PVAV))));
3345     AvREAL_off(PL_dbargs);
3346     PL_DBgv = gv_fetchpv("DB", GV_ADDMULTI, SVt_PVGV);
3347     PL_DBline = gv_fetchpv("dbline", GV_ADDMULTI, SVt_PVAV);
3348     PL_DBsub = gv_HVadd(gv_fetchpv("sub", GV_ADDMULTI, SVt_PVHV));
3349     sv_upgrade(GvSV(PL_DBsub), SVt_IV); /* IVX accessed if PERLDB_SUB_NN */
3350     PL_DBsingle = GvSV((gv_fetchpv("single", GV_ADDMULTI, SVt_PV)));
3351     sv_setiv(PL_DBsingle, 0);
3352     PL_DBtrace = GvSV((gv_fetchpv("trace", GV_ADDMULTI, SVt_PV)));
3353     sv_setiv(PL_DBtrace, 0);
3354     PL_DBsignal = GvSV((gv_fetchpv("signal", GV_ADDMULTI, SVt_PV)));
3355     sv_setiv(PL_DBsignal, 0);
3356     PL_curstash = ostash;
3357 }
3358
3359 #ifndef STRESS_REALLOC
3360 #define REASONABLE(size) (size)
3361 #else
3362 #define REASONABLE(size) (1) /* unreasonable */
3363 #endif
3364
3365 void
3366 Perl_init_stacks(pTHX)
3367 {
3368     /* start with 128-item stack and 8K cxstack */
3369     PL_curstackinfo = new_stackinfo(REASONABLE(128),
3370                                  REASONABLE(8192/sizeof(PERL_CONTEXT) - 1));
3371     PL_curstackinfo->si_type = PERLSI_MAIN;
3372     PL_curstack = PL_curstackinfo->si_stack;
3373     PL_mainstack = PL_curstack;         /* remember in case we switch stacks */
3374
3375     PL_stack_base = AvARRAY(PL_curstack);
3376     PL_stack_sp = PL_stack_base;
3377     PL_stack_max = PL_stack_base + AvMAX(PL_curstack);
3378
3379     New(50,PL_tmps_stack,REASONABLE(128),SV*);
3380     PL_tmps_floor = -1;
3381     PL_tmps_ix = -1;
3382     PL_tmps_max = REASONABLE(128);
3383
3384     New(54,PL_markstack,REASONABLE(32),I32);
3385     PL_markstack_ptr = PL_markstack;
3386     PL_markstack_max = PL_markstack + REASONABLE(32);
3387
3388     SET_MARK_OFFSET;
3389
3390     New(54,PL_scopestack,REASONABLE(32),I32);
3391     PL_scopestack_ix = 0;
3392     PL_scopestack_max = REASONABLE(32);
3393
3394     New(54,PL_savestack,REASONABLE(128),ANY);
3395     PL_savestack_ix = 0;
3396     PL_savestack_max = REASONABLE(128);
3397
3398     New(54,PL_retstack,REASONABLE(16),OP*);
3399     PL_retstack_ix = 0;
3400     PL_retstack_max = REASONABLE(16);
3401 }
3402
3403 #undef REASONABLE
3404
3405 STATIC void
3406 S_nuke_stacks(pTHX)
3407 {
3408     while (PL_curstackinfo->si_next)
3409         PL_curstackinfo = PL_curstackinfo->si_next;
3410     while (PL_curstackinfo) {
3411         PERL_SI *p = PL_curstackinfo->si_prev;
3412         /* curstackinfo->si_stack got nuked by sv_free_arenas() */
3413         Safefree(PL_curstackinfo->si_cxstack);
3414         Safefree(PL_curstackinfo);
3415         PL_curstackinfo = p;
3416     }
3417     Safefree(PL_tmps_stack);
3418     Safefree(PL_markstack);
3419     Safefree(PL_scopestack);
3420     Safefree(PL_savestack);
3421     Safefree(PL_retstack);
3422 }
3423
3424 STATIC void
3425 S_init_lexer(pTHX)
3426 {
3427     PerlIO *tmpfp;
3428     tmpfp = PL_rsfp;
3429     PL_rsfp = Nullfp;
3430     lex_start(PL_linestr);
3431     PL_rsfp = tmpfp;
3432     PL_subname = newSVpvn("main",4);
3433 }
3434
3435 STATIC void
3436 S_init_predump_symbols(pTHX)
3437 {
3438     GV *tmpgv;
3439     IO *io;
3440
3441     sv_setpvn(get_sv("\"", TRUE), " ", 1);
3442     PL_stdingv = gv_fetchpv("STDIN",TRUE, SVt_PVIO);
3443     GvMULTI_on(PL_stdingv);
3444     io = GvIOp(PL_stdingv);
3445     IoTYPE(io) = IoTYPE_RDONLY;
3446     IoIFP(io) = PerlIO_stdin();
3447     tmpgv = gv_fetchpv("stdin",TRUE, SVt_PV);
3448     GvMULTI_on(tmpgv);
3449     GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io);
3450
3451     tmpgv = gv_fetchpv("STDOUT",TRUE, SVt_PVIO);
3452     GvMULTI_on(tmpgv);
3453     io = GvIOp(tmpgv);
3454     IoTYPE(io) = IoTYPE_WRONLY;
3455     IoOFP(io) = IoIFP(io) = PerlIO_stdout();
3456     setdefout(tmpgv);
3457     tmpgv = gv_fetchpv("stdout",TRUE, SVt_PV);
3458     GvMULTI_on(tmpgv);
3459     GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io);
3460
3461     PL_stderrgv = gv_fetchpv("STDERR",TRUE, SVt_PVIO);
3462     GvMULTI_on(PL_stderrgv);
3463     io = GvIOp(PL_stderrgv);
3464     IoTYPE(io) = IoTYPE_WRONLY;
3465     IoOFP(io) = IoIFP(io) = PerlIO_stderr();
3466     tmpgv = gv_fetchpv("stderr",TRUE, SVt_PV);
3467     GvMULTI_on(tmpgv);
3468     GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io);
3469
3470     PL_statname = NEWSV(66,0);          /* last filename we did stat on */
3471
3472     if (PL_osname)
3473         Safefree(PL_osname);
3474     PL_osname = savepv(OSNAME);
3475 }
3476
3477 void
3478 Perl_init_argv_symbols(pTHX_ register int argc, register char **argv)
3479 {
3480     char *s;
3481     argc--,argv++;      /* skip name of script */
3482     if (PL_doswitches) {
3483         for (; argc > 0 && **argv == '-'; argc--,argv++) {
3484             if (!argv[0][1])
3485                 break;
3486             if (argv[0][1] == '-' && !argv[0][2]) {
3487                 argc--,argv++;
3488                 break;
3489             }
3490             if ((s = strchr(argv[0], '='))) {
3491                 *s++ = '\0';
3492                 sv_setpv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),s);
3493             }
3494             else
3495                 sv_setiv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),1);
3496         }
3497     }
3498     if ((PL_argvgv = gv_fetchpv("ARGV",TRUE, SVt_PVAV))) {
3499         GvMULTI_on(PL_argvgv);
3500         (void)gv_AVadd(PL_argvgv);
3501         av_clear(GvAVn(PL_argvgv));
3502         for (; argc > 0; argc--,argv++) {
3503             SV *sv = newSVpv(argv[0],0);
3504             av_push(GvAVn(PL_argvgv),sv);
3505             if (PL_widesyscalls)
3506                 (void)sv_utf8_decode(sv);
3507         }
3508     }
3509 }
3510
3511 #ifdef HAS_PROCSELFEXE
3512 /* This is a function so that we don't hold on to MAXPATHLEN
3513    bytes of stack longer than necessary
3514  */
3515 STATIC void
3516 S_procself_val(pTHX_ SV *sv, char *arg0)
3517 {
3518     char buf[MAXPATHLEN];
3519     int len = readlink(PROCSELFEXE_PATH, buf, sizeof(buf) - 1);
3520     /* FreeBSD's implementation is acknowledged to be imperfect, sometimes
3521        returning the text "unknown" from the readlink rather than the path
3522        to the executable (or returning an error from the readlink).  Any valid
3523        path has a '/' in it somewhere, so use that to validate the result.
3524        See http://www.freebsd.org/cgi/query-pr.cgi?pr=35703
3525     */
3526     if (len > 0 && memchr(buf, '/', len)) {
3527         sv_setpvn(sv,buf,len);
3528     }
3529     else {
3530         sv_setpv(sv,arg0);
3531     }
3532 }
3533 #endif /* HAS_PROCSELFEXE */
3534
3535 STATIC void
3536 S_init_postdump_symbols(pTHX_ register int argc, register char **argv, register char **env)
3537 {
3538     char *s;
3539     SV *sv;
3540     GV* tmpgv;
3541
3542     PL_toptarget = NEWSV(0,0);
3543     sv_upgrade(PL_toptarget, SVt_PVFM);
3544     sv_setpvn(PL_toptarget, "", 0);
3545     PL_bodytarget = NEWSV(0,0);
3546     sv_upgrade(PL_bodytarget, SVt_PVFM);
3547     sv_setpvn(PL_bodytarget, "", 0);
3548     PL_formtarget = PL_bodytarget;
3549
3550     TAINT;
3551
3552     init_argv_symbols(argc,argv);
3553
3554     if ((tmpgv = gv_fetchpv("0",TRUE, SVt_PV))) {
3555 #ifdef MACOS_TRADITIONAL
3556         /* $0 is not majick on a Mac */
3557         sv_setpv(GvSV(tmpgv),MacPerl_MPWFileName(PL_origfilename));
3558 #else
3559         sv_setpv(GvSV(tmpgv),PL_origfilename);
3560         magicname("0", "0", 1);
3561 #endif
3562     }
3563     if ((tmpgv = gv_fetchpv("\030",TRUE, SVt_PV))) {/* $^X */
3564 #ifdef HAS_PROCSELFEXE
3565         S_procself_val(aTHX_ GvSV(tmpgv), PL_origargv[0]);
3566 #else
3567 #ifdef OS2
3568         sv_setpv(GvSV(tmpgv), os2_execname(aTHX));
3569 #else
3570         sv_setpv(GvSV(tmpgv),PL_origargv[0]);
3571 #endif
3572 #endif
3573     }
3574     if ((PL_envgv = gv_fetchpv("ENV",TRUE, SVt_PVHV))) {
3575         HV *hv;
3576         GvMULTI_on(PL_envgv);
3577         hv = GvHVn(PL_envgv);
3578         hv_magic(hv, Nullgv, PERL_MAGIC_env);
3579 #ifdef USE_ENVIRON_ARRAY
3580         /* Note that if the supplied env parameter is actually a copy
3581            of the global environ then it may now point to free'd memory
3582            if the environment has been modified since. To avoid this
3583            problem we treat env==NULL as meaning 'use the default'
3584         */
3585         if (!env)
3586             env = environ;
3587         if (env != environ
3588 #  ifdef USE_ITHREADS
3589             && PL_curinterp == aTHX
3590 #  endif
3591            )
3592         {
3593             environ[0] = Nullch;
3594         }
3595         if (env)
3596           for (; *env; env++) {
3597             if (!(s = strchr(*env,'=')))
3598                 continue;
3599 #if defined(MSDOS)
3600             *s = '\0';
3601             (void)strupr(*env);
3602             *s = '=';
3603 #endif
3604             sv = newSVpv(s+1, 0);
3605             (void)hv_store(hv, *env, s - *env, sv, 0);
3606             if (env != environ)
3607                 mg_set(sv);
3608           }
3609 #endif /* USE_ENVIRON_ARRAY */
3610     }
3611     TAINT_NOT;
3612     if ((tmpgv = gv_fetchpv("$",TRUE, SVt_PV))) {
3613         SvREADONLY_off(GvSV(tmpgv));
3614         sv_setiv(GvSV(tmpgv), (IV)PerlProc_getpid());
3615         SvREADONLY_on(GvSV(tmpgv));
3616     }
3617
3618     /* touch @F array to prevent spurious warnings 20020415 MJD */
3619     if (PL_minus_a) {
3620       (void) get_av("main::F", TRUE | GV_ADDMULTI);
3621     }
3622     /* touch @- and @+ arrays to prevent spurious warnings 20020415 MJD */
3623     (void) get_av("main::-", TRUE | GV_ADDMULTI);
3624     (void) get_av("main::+", TRUE | GV_ADDMULTI);
3625 }
3626
3627 STATIC void
3628 S_init_perllib(pTHX)
3629 {
3630     char *s;
3631     if (!PL_tainting) {
3632 #ifndef VMS
3633         s = PerlEnv_getenv("PERL5LIB");
3634         if (s)
3635             incpush(s, TRUE, TRUE);
3636         else
3637             incpush(PerlEnv_getenv("PERLLIB"), FALSE, FALSE);
3638 #else /* VMS */
3639         /* Treat PERL5?LIB as a possible search list logical name -- the
3640          * "natural" VMS idiom for a Unix path string.  We allow each
3641          * element to be a set of |-separated directories for compatibility.
3642          */
3643         char buf[256];
3644         int idx = 0;
3645         if (my_trnlnm("PERL5LIB",buf,0))
3646             do { incpush(buf,TRUE,TRUE); } while (my_trnlnm("PERL5LIB",buf,++idx));
3647         else
3648             while (my_trnlnm("PERLLIB",buf,idx++)) incpush(buf,FALSE,FALSE);
3649 #endif /* VMS */
3650     }
3651
3652 /* Use the ~-expanded versions of APPLLIB (undocumented),
3653     ARCHLIB PRIVLIB SITEARCH SITELIB VENDORARCH and VENDORLIB
3654 */
3655 #ifdef APPLLIB_EXP
3656     incpush(APPLLIB_EXP, TRUE, TRUE);
3657 #endif
3658
3659 #ifdef ARCHLIB_EXP
3660     incpush(ARCHLIB_EXP, FALSE, FALSE);
3661 #endif
3662 #ifdef MACOS_TRADITIONAL
3663     {
3664         Stat_t tmpstatbuf;
3665         SV * privdir = NEWSV(55, 0);
3666         char * macperl = PerlEnv_getenv("MACPERL");
3667
3668         if (!macperl)
3669             macperl = "";
3670
3671         Perl_sv_setpvf(aTHX_ privdir, "%slib:", macperl);
3672         if (PerlLIO_stat(SvPVX(privdir), &tmpstatbuf) >= 0 && S_ISDIR(tmpstatbuf.st_mode))
3673             incpush(SvPVX(privdir), TRUE, FALSE);
3674         Perl_sv_setpvf(aTHX_ privdir, "%ssite_perl:", macperl);
3675         if (PerlLIO_stat(SvPVX(privdir), &tmpstatbuf) >= 0 && S_ISDIR(tmpstatbuf.st_mode))
3676             incpush(SvPVX(privdir), TRUE, FALSE);
3677
3678         SvREFCNT_dec(privdir);
3679     }
3680     if (!PL_tainting)
3681         incpush(":", FALSE, FALSE);
3682 #else
3683 #ifndef PRIVLIB_EXP
3684 #  define PRIVLIB_EXP "/usr/local/lib/perl5:/usr/local/lib/perl"
3685 #endif
3686 #if defined(WIN32)
3687     incpush(PRIVLIB_EXP, TRUE, FALSE);
3688 #else
3689     incpush(PRIVLIB_EXP, FALSE, FALSE);
3690 #endif
3691
3692 #ifdef SITEARCH_EXP
3693     /* sitearch is always relative to sitelib on Windows for
3694      * DLL-based path intuition to work correctly */
3695 #  if !defined(WIN32)
3696     incpush(SITEARCH_EXP, FALSE, FALSE);
3697 #  endif
3698 #endif
3699
3700 #ifdef SITELIB_EXP
3701 #  if defined(WIN32)
3702     incpush(SITELIB_EXP, TRUE, FALSE);  /* this picks up sitearch as well */
3703 #  else
3704     incpush(SITELIB_EXP, FALSE, FALSE);
3705 #  endif
3706 #endif
3707
3708 #ifdef SITELIB_STEM /* Search for version-specific dirs below here */
3709     incpush(SITELIB_STEM, FALSE, TRUE);
3710 #endif
3711
3712 #ifdef PERL_VENDORARCH_EXP
3713     /* vendorarch is always relative to vendorlib on Windows for
3714      * DLL-based path intuition to work correctly */
3715 #  if !defined(WIN32)
3716     incpush(PERL_VENDORARCH_EXP, FALSE, FALSE);
3717 #  endif
3718 #endif
3719
3720 #ifdef PERL_VENDORLIB_EXP
3721 #  if defined(WIN32)
3722     incpush(PERL_VENDORLIB_EXP, TRUE, FALSE);   /* this picks up vendorarch as well */
3723 #  else
3724     incpush(PERL_VENDORLIB_EXP, FALSE, FALSE);
3725 #  endif
3726 #endif
3727
3728 #ifdef PERL_VENDORLIB_STEM /* Search for version-specific dirs below here */
3729     incpush(PERL_VENDORLIB_STEM, FALSE, TRUE);
3730 #endif
3731
3732 #ifdef PERL_OTHERLIBDIRS
3733     incpush(PERL_OTHERLIBDIRS, TRUE, TRUE);
3734 #endif
3735
3736     if (!PL_tainting)
3737         incpush(".", FALSE, FALSE);
3738 #endif /* MACOS_TRADITIONAL */
3739 }
3740
3741 #if defined(DOSISH) || defined(EPOC)
3742 #    define PERLLIB_SEP ';'
3743 #else
3744 #  if defined(VMS)
3745 #    define PERLLIB_SEP '|'
3746 #  else
3747 #    if defined(MACOS_TRADITIONAL)
3748 #      define PERLLIB_SEP ','
3749 #    else
3750 #      define PERLLIB_SEP ':'
3751 #    endif
3752 #  endif
3753 #endif
3754 #ifndef PERLLIB_MANGLE
3755 #  define PERLLIB_MANGLE(s,n) (s)
3756 #endif
3757
3758 STATIC void
3759 S_incpush(pTHX_ char *p, int addsubdirs, int addoldvers)
3760 {
3761     SV *subdir = Nullsv;
3762
3763     if (!p || !*p)
3764         return;
3765
3766     if (addsubdirs || addoldvers) {
3767         subdir = sv_newmortal();
3768     }
3769
3770     /* Break at all separators */
3771     while (p && *p) {
3772         SV *libdir = NEWSV(55,0);
3773         char *s;
3774
3775         /* skip any consecutive separators */
3776         while ( *p == PERLLIB_SEP ) {
3777             /* Uncomment the next line for PATH semantics */
3778             /* av_push(GvAVn(PL_incgv), newSVpvn(".", 1)); */
3779             p++;
3780         }
3781
3782         if ( (s = strchr(p, PERLLIB_SEP)) != Nullch ) {
3783             sv_setpvn(libdir, PERLLIB_MANGLE(p, (STRLEN)(s - p)),
3784                       (STRLEN)(s - p));
3785             p = s + 1;
3786         }
3787         else {
3788             sv_setpv(libdir, PERLLIB_MANGLE(p, 0));
3789             p = Nullch; /* break out */
3790         }
3791 #ifdef MACOS_TRADITIONAL
3792         if (!strchr(SvPVX(libdir), ':')) {
3793             char buf[256];
3794
3795             sv_setpv(libdir, MacPerl_CanonDir(SvPVX(libdir), buf, 0));
3796         }
3797         if (SvPVX(libdir)[SvCUR(libdir)-1] != ':')
3798             sv_catpv(libdir, ":");
3799 #endif
3800
3801         /*
3802          * BEFORE pushing libdir onto @INC we may first push version- and
3803          * archname-specific sub-directories.
3804          */
3805         if (addsubdirs || addoldvers) {
3806 #ifdef PERL_INC_VERSION_LIST
3807             /* Configure terminates PERL_INC_VERSION_LIST with a NULL */
3808             const char *incverlist[] = { PERL_INC_VERSION_LIST };
3809             const char **incver;
3810 #endif
3811             Stat_t tmpstatbuf;
3812 #ifdef VMS
3813             char *unix;
3814             STRLEN len;
3815
3816             if ((unix = tounixspec_ts(SvPV(libdir,len),Nullch)) != Nullch) {
3817                 len = strlen(unix);
3818                 while (unix[len-1] == '/') len--;  /* Cosmetic */
3819                 sv_usepvn(libdir,unix,len);
3820             }
3821             else
3822                 PerlIO_printf(Perl_error_log,
3823                               "Failed to unixify @INC element \"%s\"\n",
3824                               SvPV(libdir,len));
3825 #endif
3826             if (addsubdirs) {
3827 #ifdef MACOS_TRADITIONAL
3828 #define PERL_AV_SUFFIX_FMT      ""
3829 #define PERL_ARCH_FMT           "%s:"
3830 #define PERL_ARCH_FMT_PATH      PERL_FS_VER_FMT PERL_AV_SUFFIX_FMT
3831 #else
3832 #define PERL_AV_SUFFIX_FMT      "/"
3833 #define PERL_ARCH_FMT           "/%s"
3834 #define PERL_ARCH_FMT_PATH      PERL_AV_SUFFIX_FMT PERL_FS_VER_FMT
3835 #endif
3836                 /* .../version/archname if -d .../version/archname */
3837                 Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_ARCH_FMT_PATH PERL_ARCH_FMT,
3838                                 libdir,
3839                                (int)PERL_REVISION, (int)PERL_VERSION,
3840                                (int)PERL_SUBVERSION, ARCHNAME);
3841                 if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
3842                       S_ISDIR(tmpstatbuf.st_mode))
3843                     av_push(GvAVn(PL_incgv), newSVsv(subdir));
3844
3845                 /* .../version if -d .../version */
3846                 Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_ARCH_FMT_PATH, libdir,
3847                                (int)PERL_REVISION, (int)PERL_VERSION,
3848                                (int)PERL_SUBVERSION);
3849                 if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
3850                       S_ISDIR(tmpstatbuf.st_mode))
3851                     av_push(GvAVn(PL_incgv), newSVsv(subdir));
3852
3853                 /* .../archname if -d .../archname */
3854                 Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_ARCH_FMT, libdir, ARCHNAME);
3855                 if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
3856                       S_ISDIR(tmpstatbuf.st_mode))
3857                     av_push(GvAVn(PL_incgv), newSVsv(subdir));
3858             }
3859
3860 #ifdef PERL_INC_VERSION_LIST
3861             if (addoldvers) {
3862                 for (incver = incverlist; *incver; incver++) {
3863                     /* .../xxx if -d .../xxx */
3864                     Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_ARCH_FMT, libdir, *incver);
3865                     if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
3866                           S_ISDIR(tmpstatbuf.st_mode))
3867                         av_push(GvAVn(PL_incgv), newSVsv(subdir));
3868                 }
3869             }
3870 #endif
3871         }
3872
3873         /* finally push this lib directory on the end of @INC */
3874         av_push(GvAVn(PL_incgv), libdir);
3875     }
3876 }
3877
3878 #ifdef USE_5005THREADS
3879 STATIC struct perl_thread *
3880 S_init_main_thread(pTHX)
3881 {
3882 #if !defined(PERL_IMPLICIT_CONTEXT)
3883     struct perl_thread *thr;
3884 #endif
3885     XPV *xpv;
3886
3887     Newz(53, thr, 1, struct perl_thread);
3888     PL_curcop = &PL_compiling;
3889     thr->interp = PERL_GET_INTERP;
3890     thr->cvcache = newHV();
3891     thr->threadsv = newAV();
3892     /* thr->threadsvp is set when find_threadsv is called */
3893     thr->specific = newAV();
3894     thr->flags = THRf_R_JOINABLE;
3895     MUTEX_INIT(&thr->mutex);
3896     /* Handcraft thrsv similarly to mess_sv */
3897     New(53, PL_thrsv, 1, SV);
3898     Newz(53, xpv, 1, XPV);
3899     SvFLAGS(PL_thrsv) = SVt_PV;
3900     SvANY(PL_thrsv) = (void*)xpv;
3901     SvREFCNT(PL_thrsv) = 1 << 30;       /* practically infinite */
3902     SvPVX(PL_thrsv) = (char*)thr;
3903     SvCUR_set(PL_thrsv, sizeof(thr));
3904     SvLEN_set(PL_thrsv, sizeof(thr));
3905     *SvEND(PL_thrsv) = '\0';    /* in the trailing_nul field */
3906     thr->oursv = PL_thrsv;
3907     PL_chopset = " \n-";
3908     PL_dumpindent = 4;
3909
3910     MUTEX_LOCK(&PL_threads_mutex);
3911     PL_nthreads++;
3912     thr->tid = 0;
3913     thr->next = thr;
3914     thr->prev = thr;
3915     thr->thr_done = 0;
3916     MUTEX_UNLOCK(&PL_threads_mutex);
3917
3918 #ifdef HAVE_THREAD_INTERN
3919     Perl_init_thread_intern(thr);
3920 #endif
3921
3922 #ifdef SET_THREAD_SELF
3923     SET_THREAD_SELF(thr);
3924 #else
3925     thr->self = pthread_self();
3926 #endif /* SET_THREAD_SELF */
3927     PERL_SET_THX(thr);
3928
3929     /*
3930      * These must come after the thread self setting
3931      * because sv_setpvn does SvTAINT and the taint
3932      * fields thread selfness being set.
3933      */
3934     PL_toptarget = NEWSV(0,0);
3935     sv_upgrade(PL_toptarget, SVt_PVFM);
3936     sv_setpvn(PL_toptarget, "", 0);
3937     PL_bodytarget = NEWSV(0,0);
3938     sv_upgrade(PL_bodytarget, SVt_PVFM);
3939     sv_setpvn(PL_bodytarget, "", 0);
3940     PL_formtarget = PL_bodytarget;
3941     thr->errsv = newSVpvn("", 0);
3942     (void) find_threadsv("@");  /* Ensure $@ is initialised early */
3943
3944     PL_maxscream = -1;
3945     PL_peepp = MEMBER_TO_FPTR(Perl_peep);
3946     PL_regcompp = MEMBER_TO_FPTR(Perl_pregcomp);
3947     PL_regexecp = MEMBER_TO_FPTR(Perl_regexec_flags);
3948     PL_regint_start = MEMBER_TO_FPTR(Perl_re_intuit_start);
3949     PL_regint_string = MEMBER_TO_FPTR(Perl_re_intuit_string);
3950     PL_regfree = MEMBER_TO_FPTR(Perl_pregfree);
3951     PL_regindent = 0;
3952     PL_reginterp_cnt = 0;
3953
3954     return thr;
3955 }
3956 #endif /* USE_5005THREADS */
3957
3958 void
3959 Perl_call_list(pTHX_ I32 oldscope, AV *paramList)
3960 {
3961     SV *atsv;
3962     line_t oldline = CopLINE(PL_curcop);
3963     CV *cv;
3964     STRLEN len;
3965     int ret;
3966     dJMPENV;
3967
3968     while (AvFILL(paramList) >= 0) {
3969         cv = (CV*)av_shift(paramList);
3970         if (PL_savebegin && (paramList == PL_beginav)) {
3971                 /* save PL_beginav for compiler */
3972             if (! PL_beginav_save)
3973                 PL_beginav_save = newAV();
3974             av_push(PL_beginav_save, (SV*)cv);
3975         } else {
3976             SAVEFREESV(cv);
3977         }
3978 #ifdef PERL_FLEXIBLE_EXCEPTIONS
3979         CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_vcall_list_body), cv);
3980 #else
3981         JMPENV_PUSH(ret);
3982 #endif
3983         switch (ret) {
3984         case 0:
3985 #ifndef PERL_FLEXIBLE_EXCEPTIONS
3986             call_list_body(cv);
3987 #endif
3988             atsv = ERRSV;
3989             (void)SvPV(atsv, len);
3990             if (len) {
3991                 STRLEN n_a;
3992                 PL_curcop = &PL_compiling;
3993                 CopLINE_set(PL_curcop, oldline);
3994                 if (paramList == PL_beginav)
3995                     sv_catpv(atsv, "BEGIN failed--compilation aborted");
3996                 else
3997                     Perl_sv_catpvf(aTHX_ atsv,
3998                                    "%s failed--call queue aborted",
3999                                    paramList == PL_checkav ? "CHECK"
4000                                    : paramList == PL_initav ? "INIT"
4001                                    : "END");
4002                 while (PL_scopestack_ix > oldscope)
4003                     LEAVE;
4004                 JMPENV_POP;
4005                 Perl_croak(aTHX_ "%s", SvPVx(atsv, n_a));
4006             }
4007             break;
4008         case 1:
4009             STATUS_ALL_FAILURE;
4010             /* FALL THROUGH */
4011         case 2:
4012             /* my_exit() was called */
4013             while (PL_scopestack_ix > oldscope)
4014                 LEAVE;
4015             FREETMPS;
4016             PL_curstash = PL_defstash;
4017             PL_curcop = &PL_compiling;
4018             CopLINE_set(PL_curcop, oldline);
4019             JMPENV_POP;
4020             if (PL_statusvalue && !(PL_exit_flags & PERL_EXIT_EXPECTED)) {
4021                 if (paramList == PL_beginav)
4022                     Perl_croak(aTHX_ "BEGIN failed--compilation aborted");
4023                 else
4024                     Perl_croak(aTHX_ "%s failed--call queue aborted",
4025                                paramList == PL_checkav ? "CHECK"
4026                                : paramList == PL_initav ? "INIT"
4027                                : "END");
4028             }
4029             my_exit_jump();
4030             /* NOTREACHED */
4031         case 3:
4032             if (PL_restartop) {
4033                 PL_curcop = &PL_compiling;
4034                 CopLINE_set(PL_curcop, oldline);
4035                 JMPENV_JUMP(3);
4036             }
4037             PerlIO_printf(Perl_error_log, "panic: restartop\n");
4038             FREETMPS;
4039             break;
4040         }
4041         JMPENV_POP;
4042     }
4043 }
4044
4045 #ifdef PERL_FLEXIBLE_EXCEPTIONS
4046 STATIC void *
4047 S_vcall_list_body(pTHX_ va_list args)
4048 {
4049     CV *cv = va_arg(args, CV*);
4050     return call_list_body(cv);
4051 }
4052 #endif
4053
4054 STATIC void *
4055 S_call_list_body(pTHX_ CV *cv)
4056 {
4057     PUSHMARK(PL_stack_sp);
4058     call_sv((SV*)cv, G_EVAL|G_DISCARD);
4059     return NULL;
4060 }
4061
4062 void
4063 Perl_my_exit(pTHX_ U32 status)
4064 {
4065     DEBUG_S(PerlIO_printf(Perl_debug_log, "my_exit: thread %p, status %lu\n",
4066                           thr, (unsigned long) status));
4067     switch (status) {
4068     case 0:
4069         STATUS_ALL_SUCCESS;
4070         break;
4071     case 1:
4072         STATUS_ALL_FAILURE;
4073         break;
4074     default:
4075         STATUS_NATIVE_SET(status);
4076         break;
4077     }
4078     my_exit_jump();
4079 }
4080
4081 void
4082 Perl_my_failure_exit(pTHX)
4083 {
4084 #ifdef VMS
4085     if (vaxc$errno & 1) {
4086         if (STATUS_NATIVE & 1)          /* fortuitiously includes "-1" */
4087             STATUS_NATIVE_SET(44);
4088     }
4089     else {
4090         if (!vaxc$errno && errno)       /* unlikely */
4091             STATUS_NATIVE_SET(44);
4092         else
4093             STATUS_NATIVE_SET(vaxc$errno);
4094     }
4095 #else
4096     int exitstatus;
4097     if (errno & 255)
4098         STATUS_POSIX_SET(errno);
4099     else {
4100         exitstatus = STATUS_POSIX >> 8;
4101         if (exitstatus & 255)
4102             STATUS_POSIX_SET(exitstatus);
4103         else
4104             STATUS_POSIX_SET(255);
4105     }
4106 #endif
4107     my_exit_jump();
4108 }
4109
4110 STATIC void
4111 S_my_exit_jump(pTHX)
4112 {
4113     register PERL_CONTEXT *cx;
4114     I32 gimme;
4115     SV **newsp;
4116
4117     if (PL_e_script) {
4118         SvREFCNT_dec(PL_e_script);
4119         PL_e_script = Nullsv;
4120     }
4121
4122     POPSTACK_TO(PL_mainstack);
4123     if (cxstack_ix >= 0) {
4124         if (cxstack_ix > 0)
4125             dounwind(0);
4126         POPBLOCK(cx,PL_curpm);
4127         LEAVE;
4128     }
4129
4130     JMPENV_JUMP(2);
4131 }
4132
4133 static I32
4134 read_e_script(pTHX_ int idx, SV *buf_sv, int maxlen)
4135 {
4136     char *p, *nl;
4137     p  = SvPVX(PL_e_script);
4138     nl = strchr(p, '\n');
4139     nl = (nl) ? nl+1 : SvEND(PL_e_script);
4140     if (nl-p == 0) {
4141         filter_del(read_e_script);
4142         return 0;
4143     }
4144     sv_catpvn(buf_sv, p, nl-p);
4145     sv_chop(PL_e_script, nl);
4146     return 1;
4147 }