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