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