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