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