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     PL_curstash = PL_defstash = newHV();
2690     PL_curstname = newSVpvn("main",4);
2691     gv = gv_fetchpv("main::",TRUE, SVt_PVHV);
2692     SvREFCNT_dec(GvHV(gv));
2693     GvHV(gv) = (HV*)SvREFCNT_inc(PL_defstash);
2694     SvREADONLY_on(gv);
2695     HvNAME(PL_defstash) = savepv("main");
2696     PL_incgv = gv_HVadd(gv_AVadd(gv_fetchpv("INC",TRUE, SVt_PVAV)));
2697     GvMULTI_on(PL_incgv);
2698     PL_hintgv = gv_fetchpv("\010",TRUE, SVt_PV); /* ^H */
2699     GvMULTI_on(PL_hintgv);
2700     PL_defgv = gv_fetchpv("_",TRUE, SVt_PVAV);
2701     PL_errgv = gv_HVadd(gv_fetchpv("@", TRUE, SVt_PV));
2702     GvMULTI_on(PL_errgv);
2703     PL_replgv = gv_fetchpv("\022", TRUE, SVt_PV); /* ^R */
2704     GvMULTI_on(PL_replgv);
2705     (void)Perl_form(aTHX_ "%240s","");  /* Preallocate temp - for immediate signals. */
2706     sv_grow(ERRSV, 240);        /* Preallocate - for immediate signals. */
2707     sv_setpvn(ERRSV, "", 0);
2708     PL_curstash = PL_defstash;
2709     CopSTASH_set(&PL_compiling, PL_defstash);
2710     PL_debstash = GvHV(gv_fetchpv("DB::", GV_ADDMULTI, SVt_PVHV));
2711     PL_globalstash = GvHV(gv_fetchpv("CORE::GLOBAL::", GV_ADDMULTI, SVt_PVHV));
2712     PL_nullstash = GvHV(gv_fetchpv("<none>::", GV_ADDMULTI, SVt_PVHV));
2713     /* We must init $/ before switches are processed. */
2714     sv_setpvn(get_sv("/", TRUE), "\n", 1);
2715 }
2716
2717 STATIC void
2718 S_open_script(pTHX_ char *scriptname, bool dosearch, SV *sv, int *fdscript)
2719 {
2720     char *quote;
2721     char *code;
2722     char *cpp_discard_flag;
2723     char *perl;
2724
2725     *fdscript = -1;
2726
2727     if (PL_e_script) {
2728         PL_origfilename = savepv("-e");
2729     }
2730     else {
2731         /* if find_script() returns, it returns a malloc()-ed value */
2732         PL_origfilename = scriptname = find_script(scriptname, dosearch, NULL, 1);
2733
2734         if (strnEQ(scriptname, "/dev/fd/", 8) && isDIGIT(scriptname[8]) ) {
2735             char *s = scriptname + 8;
2736             *fdscript = atoi(s);
2737             while (isDIGIT(*s))
2738                 s++;
2739             if (*s) {
2740                 scriptname = savepv(s + 1);
2741                 Safefree(PL_origfilename);
2742                 PL_origfilename = scriptname;
2743             }
2744         }
2745     }
2746
2747     CopFILE_free(PL_curcop);
2748     CopFILE_set(PL_curcop, PL_origfilename);
2749     if (strEQ(PL_origfilename,"-"))
2750         scriptname = "";
2751     if (*fdscript >= 0) {
2752         PL_rsfp = PerlIO_fdopen(*fdscript,PERL_SCRIPT_MODE);
2753 #       if defined(HAS_FCNTL) && defined(F_SETFD)
2754             if (PL_rsfp)
2755                 /* ensure close-on-exec */
2756                 fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,1);
2757 #       endif
2758     }
2759     else if (PL_preprocess) {
2760         char *cpp_cfg = CPPSTDIN;
2761         SV *cpp = newSVpvn("",0);
2762         SV *cmd = NEWSV(0,0);
2763
2764         if (strEQ(cpp_cfg, "cppstdin"))
2765             Perl_sv_catpvf(aTHX_ cpp, "%s/", BIN_EXP);
2766         sv_catpv(cpp, cpp_cfg);
2767
2768 #       ifndef VMS
2769             sv_catpvn(sv, "-I", 2);
2770             sv_catpv(sv,PRIVLIB_EXP);
2771 #       endif
2772
2773         DEBUG_P(PerlIO_printf(Perl_debug_log,
2774                               "PL_preprocess: scriptname=\"%s\", cpp=\"%s\", sv=\"%s\", CPPMINUS=\"%s\"\n",
2775                               scriptname, SvPVX (cpp), SvPVX (sv), CPPMINUS));
2776
2777 #       if defined(MSDOS) || defined(WIN32) || defined(VMS)
2778             quote = "\"";
2779 #       else
2780             quote = "'";
2781 #       endif
2782
2783 #       ifdef VMS
2784             cpp_discard_flag = "";
2785 #       else
2786             cpp_discard_flag = "-C";
2787 #       endif
2788
2789 #       ifdef OS2
2790             perl = os2_execname(aTHX);
2791 #       else
2792             perl = PL_origargv[0];
2793 #       endif
2794
2795
2796         /* This strips off Perl comments which might interfere with
2797            the C pre-processor, including #!.  #line directives are
2798            deliberately stripped to avoid confusion with Perl's version
2799            of #line.  FWP played some golf with it so it will fit
2800            into VMS's 255 character buffer.
2801         */
2802         if( PL_doextract )
2803             code = "(1../^#!.*perl/i)|/^\\s*#(?!\\s*((ifn?|un)def|(el|end)?if|define|include|else|error|pragma)\\b)/||!($|=1)||print";
2804         else
2805             code = "/^\\s*#(?!\\s*((ifn?|un)def|(el|end)?if|define|include|else|error|pragma)\\b)/||!($|=1)||print";
2806
2807         Perl_sv_setpvf(aTHX_ cmd, "\
2808 %s -ne%s%s%s %s | %"SVf" %s %"SVf" %s",
2809                        perl, quote, code, quote, scriptname, cpp,
2810                        cpp_discard_flag, sv, CPPMINUS);
2811
2812         PL_doextract = FALSE;
2813 #       ifdef IAMSUID                   /* actually, this is caught earlier */
2814             if (PL_euid != PL_uid && !PL_euid) {  /* if running suidperl */
2815 #               ifdef HAS_SETEUID
2816                     (void)seteuid(PL_uid);        /* musn't stay setuid root */
2817 #               else
2818 #               ifdef HAS_SETREUID
2819                     (void)setreuid((Uid_t)-1, PL_uid);
2820 #               else
2821 #               ifdef HAS_SETRESUID
2822                     (void)setresuid((Uid_t)-1, PL_uid, (Uid_t)-1);
2823 #               else
2824                     PerlProc_setuid(PL_uid);
2825 #               endif
2826 #               endif
2827 #               endif
2828             if (PerlProc_geteuid() != PL_uid)
2829                 Perl_croak(aTHX_ "Can't do seteuid!\n");
2830         }
2831 #       endif /* IAMSUID */
2832
2833         DEBUG_P(PerlIO_printf(Perl_debug_log,
2834                               "PL_preprocess: cmd=\"%s\"\n",
2835                               SvPVX(cmd)));
2836
2837         PL_rsfp = PerlProc_popen(SvPVX(cmd), "r");
2838         SvREFCNT_dec(cmd);
2839         SvREFCNT_dec(cpp);
2840     }
2841     else if (!*scriptname) {
2842         forbid_setid("program input from stdin");
2843         PL_rsfp = PerlIO_stdin();
2844     }
2845     else {
2846         PL_rsfp = PerlIO_open(scriptname,PERL_SCRIPT_MODE);
2847 #       if defined(HAS_FCNTL) && defined(F_SETFD)
2848             if (PL_rsfp)
2849                 /* ensure close-on-exec */
2850                 fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,1);
2851 #       endif
2852     }
2853     if (!PL_rsfp) {
2854 #       ifdef DOSUID
2855 #       ifndef IAMSUID  /* in case script is not readable before setuid */
2856             if (PL_euid &&
2857                 PerlLIO_stat(CopFILE(PL_curcop),&PL_statbuf) >= 0 &&
2858                 PL_statbuf.st_mode & (S_ISUID|S_ISGID))
2859             {
2860                 /* try again */
2861                 PerlProc_execv(Perl_form(aTHX_ "%s/sperl"PERL_FS_VER_FMT,
2862                                          BIN_EXP, (int)PERL_REVISION,
2863                                          (int)PERL_VERSION,
2864                                          (int)PERL_SUBVERSION), PL_origargv);
2865                 Perl_croak(aTHX_ "Can't do setuid\n");
2866             }
2867 #       endif
2868 #       endif
2869 #       ifdef IAMSUID
2870             errno = EPERM;
2871             Perl_croak(aTHX_ "Can't open perl script: %s\n",
2872                        Strerror(errno));
2873 #       else
2874             Perl_croak(aTHX_ "Can't open perl script \"%s\": %s\n",
2875                        CopFILE(PL_curcop), Strerror(errno));
2876 #       endif
2877     }
2878 }
2879
2880 /* Mention
2881  * I_SYSSTATVFS HAS_FSTATVFS
2882  * I_SYSMOUNT
2883  * I_STATFS     HAS_FSTATFS     HAS_GETFSSTAT
2884  * I_MNTENT     HAS_GETMNTENT   HAS_HASMNTOPT
2885  * here so that metaconfig picks them up. */
2886
2887 #ifdef IAMSUID
2888 STATIC int
2889 S_fd_on_nosuid_fs(pTHX_ int fd)
2890 {
2891     int check_okay = 0; /* able to do all the required sys/libcalls */
2892     int on_nosuid  = 0; /* the fd is on a nosuid fs */
2893 /*
2894  * Preferred order: fstatvfs(), fstatfs(), ustat()+getmnt(), getmntent().
2895  * fstatvfs() is UNIX98.
2896  * fstatfs() is 4.3 BSD.
2897  * ustat()+getmnt() is pre-4.3 BSD.
2898  * getmntent() is O(number-of-mounted-filesystems) and can hang on
2899  * an irrelevant filesystem while trying to reach the right one.
2900  */
2901
2902 #undef FD_ON_NOSUID_CHECK_OKAY  /* found the syscalls to do the check? */
2903
2904 #   if !defined(FD_ON_NOSUID_CHECK_OKAY) && \
2905         defined(HAS_FSTATVFS)
2906 #   define FD_ON_NOSUID_CHECK_OKAY
2907     struct statvfs stfs;
2908
2909     check_okay = fstatvfs(fd, &stfs) == 0;
2910     on_nosuid  = check_okay && (stfs.f_flag  & ST_NOSUID);
2911 #   endif /* fstatvfs */
2912
2913 #   if !defined(FD_ON_NOSUID_CHECK_OKAY) && \
2914         defined(PERL_MOUNT_NOSUID)      && \
2915         defined(HAS_FSTATFS)            && \
2916         defined(HAS_STRUCT_STATFS)      && \
2917         defined(HAS_STRUCT_STATFS_F_FLAGS)
2918 #   define FD_ON_NOSUID_CHECK_OKAY
2919     struct statfs  stfs;
2920
2921     check_okay = fstatfs(fd, &stfs)  == 0;
2922     on_nosuid  = check_okay && (stfs.f_flags & PERL_MOUNT_NOSUID);
2923 #   endif /* fstatfs */
2924
2925 #   if !defined(FD_ON_NOSUID_CHECK_OKAY) && \
2926         defined(PERL_MOUNT_NOSUID)      && \
2927         defined(HAS_FSTAT)              && \
2928         defined(HAS_USTAT)              && \
2929         defined(HAS_GETMNT)             && \
2930         defined(HAS_STRUCT_FS_DATA)     && \
2931         defined(NOSTAT_ONE)
2932 #   define FD_ON_NOSUID_CHECK_OKAY
2933     struct stat fdst;
2934
2935     if (fstat(fd, &fdst) == 0) {
2936         struct ustat us;
2937         if (ustat(fdst.st_dev, &us) == 0) {
2938             struct fs_data fsd;
2939             /* NOSTAT_ONE here because we're not examining fields which
2940              * vary between that case and STAT_ONE. */
2941             if (getmnt((int*)0, &fsd, (int)0, NOSTAT_ONE, us.f_fname) == 0) {
2942                 size_t cmplen = sizeof(us.f_fname);
2943                 if (sizeof(fsd.fd_req.path) < cmplen)
2944                     cmplen = sizeof(fsd.fd_req.path);
2945                 if (strnEQ(fsd.fd_req.path, us.f_fname, cmplen) &&
2946                     fdst.st_dev == fsd.fd_req.dev) {
2947                         check_okay = 1;
2948                         on_nosuid = fsd.fd_req.flags & PERL_MOUNT_NOSUID;
2949                     }
2950                 }
2951             }
2952         }
2953     }
2954 #   endif /* fstat+ustat+getmnt */
2955
2956 #   if !defined(FD_ON_NOSUID_CHECK_OKAY) && \
2957         defined(HAS_GETMNTENT)          && \
2958         defined(HAS_HASMNTOPT)          && \
2959         defined(MNTOPT_NOSUID)
2960 #   define FD_ON_NOSUID_CHECK_OKAY
2961     FILE                *mtab = fopen("/etc/mtab", "r");
2962     struct mntent       *entry;
2963     struct stat         stb, fsb;
2964
2965     if (mtab && (fstat(fd, &stb) == 0)) {
2966         while (entry = getmntent(mtab)) {
2967             if (stat(entry->mnt_dir, &fsb) == 0
2968                 && fsb.st_dev == stb.st_dev)
2969             {
2970                 /* found the filesystem */
2971                 check_okay = 1;
2972                 if (hasmntopt(entry, MNTOPT_NOSUID))
2973                     on_nosuid = 1;
2974                 break;
2975             } /* A single fs may well fail its stat(). */
2976         }
2977     }
2978     if (mtab)
2979         fclose(mtab);
2980 #   endif /* getmntent+hasmntopt */
2981
2982     if (!check_okay)
2983         Perl_croak(aTHX_ "Can't check filesystem of script \"%s\" for nosuid", PL_origfilename);
2984     return on_nosuid;
2985 }
2986 #endif /* IAMSUID */
2987
2988 STATIC void
2989 S_validate_suid(pTHX_ char *validarg, char *scriptname, int fdscript)
2990 {
2991 #ifdef IAMSUID
2992     int which;
2993 #endif
2994
2995     /* do we need to emulate setuid on scripts? */
2996
2997     /* This code is for those BSD systems that have setuid #! scripts disabled
2998      * in the kernel because of a security problem.  Merely defining DOSUID
2999      * in perl will not fix that problem, but if you have disabled setuid
3000      * scripts in the kernel, this will attempt to emulate setuid and setgid
3001      * on scripts that have those now-otherwise-useless bits set.  The setuid
3002      * root version must be called suidperl or sperlN.NNN.  If regular perl
3003      * discovers that it has opened a setuid script, it calls suidperl with
3004      * the same argv that it had.  If suidperl finds that the script it has
3005      * just opened is NOT setuid root, it sets the effective uid back to the
3006      * uid.  We don't just make perl setuid root because that loses the
3007      * effective uid we had before invoking perl, if it was different from the
3008      * uid.
3009      *
3010      * DOSUID must be defined in both perl and suidperl, and IAMSUID must
3011      * be defined in suidperl only.  suidperl must be setuid root.  The
3012      * Configure script will set this up for you if you want it.
3013      */
3014
3015 #ifdef DOSUID
3016     char *s, *s2;
3017
3018     if (PerlLIO_fstat(PerlIO_fileno(PL_rsfp),&PL_statbuf) < 0)  /* normal stat is insecure */
3019         Perl_croak(aTHX_ "Can't stat script \"%s\"",PL_origfilename);
3020     if (fdscript < 0 && PL_statbuf.st_mode & (S_ISUID|S_ISGID)) {
3021         I32 len;
3022         STRLEN n_a;
3023
3024 #ifdef IAMSUID
3025 #ifndef HAS_SETREUID
3026         /* On this access check to make sure the directories are readable,
3027          * there is actually a small window that the user could use to make
3028          * filename point to an accessible directory.  So there is a faint
3029          * chance that someone could execute a setuid script down in a
3030          * non-accessible directory.  I don't know what to do about that.
3031          * But I don't think it's too important.  The manual lies when
3032          * it says access() is useful in setuid programs.
3033          */
3034         if (PerlLIO_access(CopFILE(PL_curcop),1)) /*double check*/
3035             Perl_croak(aTHX_ "Permission denied");
3036 #else
3037         /* If we can swap euid and uid, then we can determine access rights
3038          * with a simple stat of the file, and then compare device and
3039          * inode to make sure we did stat() on the same file we opened.
3040          * Then we just have to make sure he or she can execute it.
3041          */
3042         {
3043             struct stat tmpstatbuf;
3044
3045             if (
3046 #ifdef HAS_SETREUID
3047                 setreuid(PL_euid,PL_uid) < 0
3048 #else
3049 # if HAS_SETRESUID
3050                 setresuid(PL_euid,PL_uid,(Uid_t)-1) < 0
3051 # endif
3052 #endif
3053                 || PerlProc_getuid() != PL_euid || PerlProc_geteuid() != PL_uid)
3054                 Perl_croak(aTHX_ "Can't swap uid and euid");    /* really paranoid */
3055             if (PerlLIO_stat(CopFILE(PL_curcop),&tmpstatbuf) < 0)
3056                 Perl_croak(aTHX_ "Permission denied");  /* testing full pathname here */
3057 #if defined(IAMSUID) && !defined(NO_NOSUID_CHECK)
3058             if (fd_on_nosuid_fs(PerlIO_fileno(PL_rsfp)))
3059                 Perl_croak(aTHX_ "Permission denied");
3060 #endif
3061             if (tmpstatbuf.st_dev != PL_statbuf.st_dev ||
3062                 tmpstatbuf.st_ino != PL_statbuf.st_ino) {
3063                 (void)PerlIO_close(PL_rsfp);
3064                 Perl_croak(aTHX_ "Permission denied\n");
3065             }
3066             if (
3067 #ifdef HAS_SETREUID
3068               setreuid(PL_uid,PL_euid) < 0
3069 #else
3070 # if defined(HAS_SETRESUID)
3071               setresuid(PL_uid,PL_euid,(Uid_t)-1) < 0
3072 # endif
3073 #endif
3074               || PerlProc_getuid() != PL_uid || PerlProc_geteuid() != PL_euid)
3075                 Perl_croak(aTHX_ "Can't reswap uid and euid");
3076             if (!cando(S_IXUSR,FALSE,&PL_statbuf))              /* can real uid exec? */
3077                 Perl_croak(aTHX_ "Permission denied\n");
3078         }
3079 #endif /* HAS_SETREUID */
3080 #endif /* IAMSUID */
3081
3082         if (!S_ISREG(PL_statbuf.st_mode))
3083             Perl_croak(aTHX_ "Permission denied");
3084         if (PL_statbuf.st_mode & S_IWOTH)
3085             Perl_croak(aTHX_ "Setuid/gid script is writable by world");
3086         PL_doswitches = FALSE;          /* -s is insecure in suid */
3087         CopLINE_inc(PL_curcop);
3088         if (sv_gets(PL_linestr, PL_rsfp, 0) == Nullch ||
3089           strnNE(SvPV(PL_linestr,n_a),"#!",2) ) /* required even on Sys V */
3090             Perl_croak(aTHX_ "No #! line");
3091         s = SvPV(PL_linestr,n_a)+2;
3092         if (*s == ' ') s++;
3093         while (!isSPACE(*s)) s++;
3094         for (s2 = s;  (s2 > SvPV(PL_linestr,n_a)+2 &&
3095                        (isDIGIT(s2[-1]) || strchr("._-", s2[-1])));  s2--) ;
3096         if (strnNE(s2-4,"perl",4) && strnNE(s-9,"perl",4))  /* sanity check */
3097             Perl_croak(aTHX_ "Not a perl script");
3098         while (*s == ' ' || *s == '\t') s++;
3099         /*
3100          * #! arg must be what we saw above.  They can invoke it by
3101          * mentioning suidperl explicitly, but they may not add any strange
3102          * arguments beyond what #! says if they do invoke suidperl that way.
3103          */
3104         len = strlen(validarg);
3105         if (strEQ(validarg," PHOOEY ") ||
3106             strnNE(s,validarg,len) || !isSPACE(s[len]))
3107             Perl_croak(aTHX_ "Args must match #! line");
3108
3109 #ifndef IAMSUID
3110         if (PL_euid != PL_uid && (PL_statbuf.st_mode & S_ISUID) &&
3111             PL_euid == PL_statbuf.st_uid)
3112             if (!PL_do_undump)
3113                 Perl_croak(aTHX_ "YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
3114 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
3115 #endif /* IAMSUID */
3116
3117         if (PL_euid) {  /* oops, we're not the setuid root perl */
3118             (void)PerlIO_close(PL_rsfp);
3119 #ifndef IAMSUID
3120             /* try again */
3121             PerlProc_execv(Perl_form(aTHX_ "%s/sperl"PERL_FS_VER_FMT, BIN_EXP,
3122                                      (int)PERL_REVISION, (int)PERL_VERSION,
3123                                      (int)PERL_SUBVERSION), PL_origargv);
3124 #endif
3125             Perl_croak(aTHX_ "Can't do setuid\n");
3126         }
3127
3128         if (PL_statbuf.st_mode & S_ISGID && PL_statbuf.st_gid != PL_egid) {
3129 #ifdef HAS_SETEGID
3130             (void)setegid(PL_statbuf.st_gid);
3131 #else
3132 #ifdef HAS_SETREGID
3133            (void)setregid((Gid_t)-1,PL_statbuf.st_gid);
3134 #else
3135 #ifdef HAS_SETRESGID
3136            (void)setresgid((Gid_t)-1,PL_statbuf.st_gid,(Gid_t)-1);
3137 #else
3138             PerlProc_setgid(PL_statbuf.st_gid);
3139 #endif
3140 #endif
3141 #endif
3142             if (PerlProc_getegid() != PL_statbuf.st_gid)
3143                 Perl_croak(aTHX_ "Can't do setegid!\n");
3144         }
3145         if (PL_statbuf.st_mode & S_ISUID) {
3146             if (PL_statbuf.st_uid != PL_euid)
3147 #ifdef HAS_SETEUID
3148                 (void)seteuid(PL_statbuf.st_uid);       /* all that for this */
3149 #else
3150 #ifdef HAS_SETREUID
3151                 (void)setreuid((Uid_t)-1,PL_statbuf.st_uid);
3152 #else
3153 #ifdef HAS_SETRESUID
3154                 (void)setresuid((Uid_t)-1,PL_statbuf.st_uid,(Uid_t)-1);
3155 #else
3156                 PerlProc_setuid(PL_statbuf.st_uid);
3157 #endif
3158 #endif
3159 #endif
3160             if (PerlProc_geteuid() != PL_statbuf.st_uid)
3161                 Perl_croak(aTHX_ "Can't do seteuid!\n");
3162         }
3163         else if (PL_uid) {                      /* oops, mustn't run as root */
3164 #ifdef HAS_SETEUID
3165           (void)seteuid((Uid_t)PL_uid);
3166 #else
3167 #ifdef HAS_SETREUID
3168           (void)setreuid((Uid_t)-1,(Uid_t)PL_uid);
3169 #else
3170 #ifdef HAS_SETRESUID
3171           (void)setresuid((Uid_t)-1,(Uid_t)PL_uid,(Uid_t)-1);
3172 #else
3173           PerlProc_setuid((Uid_t)PL_uid);
3174 #endif
3175 #endif
3176 #endif
3177             if (PerlProc_geteuid() != PL_uid)
3178                 Perl_croak(aTHX_ "Can't do seteuid!\n");
3179         }
3180         init_ids();
3181         if (!cando(S_IXUSR,TRUE,&PL_statbuf))
3182             Perl_croak(aTHX_ "Permission denied\n");    /* they can't do this */
3183     }
3184 #ifdef IAMSUID
3185     else if (PL_preprocess)
3186         Perl_croak(aTHX_ "-P not allowed for setuid/setgid script\n");
3187     else if (fdscript >= 0)
3188         Perl_croak(aTHX_ "fd script not allowed in suidperl\n");
3189     else
3190         Perl_croak(aTHX_ "Script is not setuid/setgid in suidperl\n");
3191
3192     /* We absolutely must clear out any saved ids here, so we */
3193     /* exec the real perl, substituting fd script for scriptname. */
3194     /* (We pass script name as "subdir" of fd, which perl will grok.) */
3195     PerlIO_rewind(PL_rsfp);
3196     PerlLIO_lseek(PerlIO_fileno(PL_rsfp),(Off_t)0,0);  /* just in case rewind didn't */
3197     for (which = 1; PL_origargv[which] && PL_origargv[which] != scriptname; which++) ;
3198     if (!PL_origargv[which])
3199         Perl_croak(aTHX_ "Permission denied");
3200     PL_origargv[which] = savepv(Perl_form(aTHX_ "/dev/fd/%d/%s",
3201                                   PerlIO_fileno(PL_rsfp), PL_origargv[which]));
3202 #if defined(HAS_FCNTL) && defined(F_SETFD)
3203     fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,0);    /* ensure no close-on-exec */
3204 #endif
3205     PerlProc_execv(Perl_form(aTHX_ "%s/perl"PERL_FS_VER_FMT, BIN_EXP,
3206                              (int)PERL_REVISION, (int)PERL_VERSION,
3207                              (int)PERL_SUBVERSION), PL_origargv);/* try again */
3208     Perl_croak(aTHX_ "Can't do setuid\n");
3209 #endif /* IAMSUID */
3210 #else /* !DOSUID */
3211     if (PL_euid != PL_uid || PL_egid != PL_gid) {       /* (suidperl doesn't exist, in fact) */
3212 #ifndef SETUID_SCRIPTS_ARE_SECURE_NOW
3213         PerlLIO_fstat(PerlIO_fileno(PL_rsfp),&PL_statbuf);      /* may be either wrapped or real suid */
3214         if ((PL_euid != PL_uid && PL_euid == PL_statbuf.st_uid && PL_statbuf.st_mode & S_ISUID)
3215             ||
3216             (PL_egid != PL_gid && PL_egid == PL_statbuf.st_gid && PL_statbuf.st_mode & S_ISGID)
3217            )
3218             if (!PL_do_undump)
3219                 Perl_croak(aTHX_ "YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
3220 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
3221 #endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
3222         /* not set-id, must be wrapped */
3223     }
3224 #endif /* DOSUID */
3225 }
3226
3227 STATIC void
3228 S_find_beginning(pTHX)
3229 {
3230     register char *s, *s2;
3231
3232     /* skip forward in input to the real script? */
3233
3234     forbid_setid("-x");
3235 #ifdef MACOS_TRADITIONAL
3236     /* Since the Mac OS does not honor #! arguments for us, we do it ourselves */
3237
3238     while (PL_doextract || gMacPerl_AlwaysExtract) {
3239         if ((s = sv_gets(PL_linestr, PL_rsfp, 0)) == Nullch) {
3240             if (!gMacPerl_AlwaysExtract)
3241                 Perl_croak(aTHX_ "No Perl script found in input\n");
3242
3243             if (PL_doextract)                   /* require explicit override ? */
3244                 if (!OverrideExtract(PL_origfilename))
3245                     Perl_croak(aTHX_ "User aborted script\n");
3246                 else
3247                     PL_doextract = FALSE;
3248
3249             /* Pater peccavi, file does not have #! */
3250             PerlIO_rewind(PL_rsfp);
3251
3252             break;
3253         }
3254 #else
3255     while (PL_doextract) {
3256         if ((s = sv_gets(PL_linestr, PL_rsfp, 0)) == Nullch)
3257             Perl_croak(aTHX_ "No Perl script found in input\n");
3258 #endif
3259         s2 = s;
3260         if (*s == '#' && s[1] == '!' && ((s = instr(s,"perl")) || (s = instr(s2,"PERL")))) {
3261             PerlIO_ungetc(PL_rsfp, '\n');               /* to keep line count right */
3262             PL_doextract = FALSE;
3263             while (*s && !(isSPACE (*s) || *s == '#')) s++;
3264             s2 = s;
3265             while (*s == ' ' || *s == '\t') s++;
3266             if (*s++ == '-') {
3267                 while (isDIGIT(s2[-1]) || strchr("-._", s2[-1])) s2--;
3268                 if (strnEQ(s2-4,"perl",4))
3269                     /*SUPPRESS 530*/
3270                     while ((s = moreswitches(s)))
3271                         ;
3272             }
3273 #ifdef MACOS_TRADITIONAL
3274             break;
3275 #endif
3276         }
3277     }
3278 }
3279
3280
3281 STATIC void
3282 S_init_ids(pTHX)
3283 {
3284     PL_uid = PerlProc_getuid();
3285     PL_euid = PerlProc_geteuid();
3286     PL_gid = PerlProc_getgid();
3287     PL_egid = PerlProc_getegid();
3288 #ifdef VMS
3289     PL_uid |= PL_gid << 16;
3290     PL_euid |= PL_egid << 16;
3291 #endif
3292     PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
3293 }
3294
3295 STATIC void
3296 S_forbid_setid(pTHX_ char *s)
3297 {
3298     if (PL_euid != PL_uid)
3299         Perl_croak(aTHX_ "No %s allowed while running setuid", s);
3300     if (PL_egid != PL_gid)
3301         Perl_croak(aTHX_ "No %s allowed while running setgid", s);
3302 }
3303
3304 void
3305 Perl_init_debugger(pTHX)
3306 {
3307     HV *ostash = PL_curstash;
3308
3309     PL_curstash = PL_debstash;
3310     PL_dbargs = GvAV(gv_AVadd((gv_fetchpv("args", GV_ADDMULTI, SVt_PVAV))));
3311     AvREAL_off(PL_dbargs);
3312     PL_DBgv = gv_fetchpv("DB", GV_ADDMULTI, SVt_PVGV);
3313     PL_DBline = gv_fetchpv("dbline", GV_ADDMULTI, SVt_PVAV);
3314     PL_DBsub = gv_HVadd(gv_fetchpv("sub", GV_ADDMULTI, SVt_PVHV));
3315     sv_upgrade(GvSV(PL_DBsub), SVt_IV); /* IVX accessed if PERLDB_SUB_NN */
3316     PL_DBsingle = GvSV((gv_fetchpv("single", GV_ADDMULTI, SVt_PV)));
3317     sv_setiv(PL_DBsingle, 0);
3318     PL_DBtrace = GvSV((gv_fetchpv("trace", GV_ADDMULTI, SVt_PV)));
3319     sv_setiv(PL_DBtrace, 0);
3320     PL_DBsignal = GvSV((gv_fetchpv("signal", GV_ADDMULTI, SVt_PV)));
3321     sv_setiv(PL_DBsignal, 0);
3322     PL_curstash = ostash;
3323 }
3324
3325 #ifndef STRESS_REALLOC
3326 #define REASONABLE(size) (size)
3327 #else
3328 #define REASONABLE(size) (1) /* unreasonable */
3329 #endif
3330
3331 void
3332 Perl_init_stacks(pTHX)
3333 {
3334     /* start with 128-item stack and 8K cxstack */
3335     PL_curstackinfo = new_stackinfo(REASONABLE(128),
3336                                  REASONABLE(8192/sizeof(PERL_CONTEXT) - 1));
3337     PL_curstackinfo->si_type = PERLSI_MAIN;
3338     PL_curstack = PL_curstackinfo->si_stack;
3339     PL_mainstack = PL_curstack;         /* remember in case we switch stacks */
3340
3341     PL_stack_base = AvARRAY(PL_curstack);
3342     PL_stack_sp = PL_stack_base;
3343     PL_stack_max = PL_stack_base + AvMAX(PL_curstack);
3344
3345     New(50,PL_tmps_stack,REASONABLE(128),SV*);
3346     PL_tmps_floor = -1;
3347     PL_tmps_ix = -1;
3348     PL_tmps_max = REASONABLE(128);
3349
3350     New(54,PL_markstack,REASONABLE(32),I32);
3351     PL_markstack_ptr = PL_markstack;
3352     PL_markstack_max = PL_markstack + REASONABLE(32);
3353
3354     SET_MARK_OFFSET;
3355
3356     New(54,PL_scopestack,REASONABLE(32),I32);
3357     PL_scopestack_ix = 0;
3358     PL_scopestack_max = REASONABLE(32);
3359
3360     New(54,PL_savestack,REASONABLE(128),ANY);
3361     PL_savestack_ix = 0;
3362     PL_savestack_max = REASONABLE(128);
3363
3364     New(54,PL_retstack,REASONABLE(16),OP*);
3365     PL_retstack_ix = 0;
3366     PL_retstack_max = REASONABLE(16);
3367 }
3368
3369 #undef REASONABLE
3370
3371 STATIC void
3372 S_nuke_stacks(pTHX)
3373 {
3374     while (PL_curstackinfo->si_next)
3375         PL_curstackinfo = PL_curstackinfo->si_next;
3376     while (PL_curstackinfo) {
3377         PERL_SI *p = PL_curstackinfo->si_prev;
3378         /* curstackinfo->si_stack got nuked by sv_free_arenas() */
3379         Safefree(PL_curstackinfo->si_cxstack);
3380         Safefree(PL_curstackinfo);
3381         PL_curstackinfo = p;
3382     }
3383     Safefree(PL_tmps_stack);
3384     Safefree(PL_markstack);
3385     Safefree(PL_scopestack);
3386     Safefree(PL_savestack);
3387     Safefree(PL_retstack);
3388 }
3389
3390 STATIC void
3391 S_init_lexer(pTHX)
3392 {
3393     PerlIO *tmpfp;
3394     tmpfp = PL_rsfp;
3395     PL_rsfp = Nullfp;
3396     lex_start(PL_linestr);
3397     PL_rsfp = tmpfp;
3398     PL_subname = newSVpvn("main",4);
3399 }
3400
3401 STATIC void
3402 S_init_predump_symbols(pTHX)
3403 {
3404     GV *tmpgv;
3405     IO *io;
3406
3407     sv_setpvn(get_sv("\"", TRUE), " ", 1);
3408     PL_stdingv = gv_fetchpv("STDIN",TRUE, SVt_PVIO);
3409     GvMULTI_on(PL_stdingv);
3410     io = GvIOp(PL_stdingv);
3411     IoTYPE(io) = IoTYPE_RDONLY;
3412     IoIFP(io) = PerlIO_stdin();
3413     tmpgv = gv_fetchpv("stdin",TRUE, SVt_PV);
3414     GvMULTI_on(tmpgv);
3415     GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io);
3416
3417     tmpgv = gv_fetchpv("STDOUT",TRUE, SVt_PVIO);
3418     GvMULTI_on(tmpgv);
3419     io = GvIOp(tmpgv);
3420     IoTYPE(io) = IoTYPE_WRONLY;
3421     IoOFP(io) = IoIFP(io) = PerlIO_stdout();
3422     setdefout(tmpgv);
3423     tmpgv = gv_fetchpv("stdout",TRUE, SVt_PV);
3424     GvMULTI_on(tmpgv);
3425     GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io);
3426
3427     PL_stderrgv = gv_fetchpv("STDERR",TRUE, SVt_PVIO);
3428     GvMULTI_on(PL_stderrgv);
3429     io = GvIOp(PL_stderrgv);
3430     IoTYPE(io) = IoTYPE_WRONLY;
3431     IoOFP(io) = IoIFP(io) = PerlIO_stderr();
3432     tmpgv = gv_fetchpv("stderr",TRUE, SVt_PV);
3433     GvMULTI_on(tmpgv);
3434     GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io);
3435
3436     PL_statname = NEWSV(66,0);          /* last filename we did stat on */
3437
3438     if (PL_osname)
3439         Safefree(PL_osname);
3440     PL_osname = savepv(OSNAME);
3441 }
3442
3443 void
3444 Perl_init_argv_symbols(pTHX_ register int argc, register char **argv)
3445 {
3446     char *s;
3447     argc--,argv++;      /* skip name of script */
3448     if (PL_doswitches) {
3449         for (; argc > 0 && **argv == '-'; argc--,argv++) {
3450             if (!argv[0][1])
3451                 break;
3452             if (argv[0][1] == '-' && !argv[0][2]) {
3453                 argc--,argv++;
3454                 break;
3455             }
3456             if ((s = strchr(argv[0], '='))) {
3457                 *s++ = '\0';
3458                 sv_setpv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),s);
3459             }
3460             else
3461                 sv_setiv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),1);
3462         }
3463     }
3464     if ((PL_argvgv = gv_fetchpv("ARGV",TRUE, SVt_PVAV))) {
3465         GvMULTI_on(PL_argvgv);
3466         (void)gv_AVadd(PL_argvgv);
3467         av_clear(GvAVn(PL_argvgv));
3468         for (; argc > 0; argc--,argv++) {
3469             SV *sv = newSVpv(argv[0],0);
3470             av_push(GvAVn(PL_argvgv),sv);
3471             if (PL_widesyscalls)
3472                 (void)sv_utf8_decode(sv);
3473         }
3474     }
3475 }
3476
3477 #ifdef HAS_PROCSELFEXE
3478 /* This is a function so that we don't hold on to MAXPATHLEN
3479    bytes of stack longer than necessary
3480  */
3481 STATIC void
3482 S_procself_val(pTHX_ SV *sv, char *arg0)
3483 {
3484     char buf[MAXPATHLEN];
3485     int len = readlink(PROCSELFEXE_PATH, buf, sizeof(buf) - 1);
3486     /* FreeBSD's implementation is acknowledged to be imperfect, sometimes
3487        returning the text "unknown" from the readlink rather than the path
3488        to the executable (or returning an error from the readlink).  Any valid
3489        path has a '/' in it somewhere, so use that to validate the result.
3490        See http://www.freebsd.org/cgi/query-pr.cgi?pr=35703
3491     */
3492     if (len > 0 && memchr(buf, '/', len)) {
3493         sv_setpvn(sv,buf,len);
3494     }
3495     else {
3496         sv_setpv(sv,arg0);
3497     }
3498 }
3499 #endif /* HAS_PROCSELFEXE */
3500
3501 STATIC void
3502 S_init_postdump_symbols(pTHX_ register int argc, register char **argv, register char **env)
3503 {
3504     char *s;
3505     SV *sv;
3506     GV* tmpgv;
3507
3508     PL_toptarget = NEWSV(0,0);
3509     sv_upgrade(PL_toptarget, SVt_PVFM);
3510     sv_setpvn(PL_toptarget, "", 0);
3511     PL_bodytarget = NEWSV(0,0);
3512     sv_upgrade(PL_bodytarget, SVt_PVFM);
3513     sv_setpvn(PL_bodytarget, "", 0);
3514     PL_formtarget = PL_bodytarget;
3515
3516     TAINT;
3517
3518     init_argv_symbols(argc,argv);
3519
3520     if ((tmpgv = gv_fetchpv("0",TRUE, SVt_PV))) {
3521 #ifdef MACOS_TRADITIONAL
3522         /* $0 is not majick on a Mac */
3523         sv_setpv(GvSV(tmpgv),MacPerl_MPWFileName(PL_origfilename));
3524 #else
3525         sv_setpv(GvSV(tmpgv),PL_origfilename);
3526         magicname("0", "0", 1);
3527 #endif
3528     }
3529     if ((tmpgv = gv_fetchpv("\030",TRUE, SVt_PV))) {/* $^X */
3530 #ifdef HAS_PROCSELFEXE
3531         S_procself_val(aTHX_ GvSV(tmpgv), PL_origargv[0]);
3532 #else
3533 #ifdef OS2
3534         sv_setpv(GvSV(tmpgv), os2_execname(aTHX));
3535 #else
3536         sv_setpv(GvSV(tmpgv),PL_origargv[0]);
3537 #endif
3538 #endif
3539     }
3540     if ((PL_envgv = gv_fetchpv("ENV",TRUE, SVt_PVHV))) {
3541         HV *hv;
3542         GvMULTI_on(PL_envgv);
3543         hv = GvHVn(PL_envgv);
3544         hv_magic(hv, Nullgv, PERL_MAGIC_env);
3545 #ifdef USE_ENVIRON_ARRAY
3546         /* Note that if the supplied env parameter is actually a copy
3547            of the global environ then it may now point to free'd memory
3548            if the environment has been modified since. To avoid this
3549            problem we treat env==NULL as meaning 'use the default'
3550         */
3551         if (!env)
3552             env = environ;
3553         if (env != environ)
3554             environ[0] = Nullch;
3555         if (env)
3556           for (; *env; env++) {
3557             if (!(s = strchr(*env,'=')))
3558                 continue;
3559 #if defined(MSDOS)
3560             *s = '\0';
3561             (void)strupr(*env);
3562             *s = '=';
3563 #endif
3564             sv = newSVpv(s+1, 0);
3565             (void)hv_store(hv, *env, s - *env, sv, 0);
3566             if (env != environ)
3567                 mg_set(sv);
3568           }
3569 #endif /* USE_ENVIRON_ARRAY */
3570     }
3571     TAINT_NOT;
3572     if ((tmpgv = gv_fetchpv("$",TRUE, SVt_PV))) {
3573         SvREADONLY_off(GvSV(tmpgv));
3574         sv_setiv(GvSV(tmpgv), (IV)PerlProc_getpid());
3575         SvREADONLY_on(GvSV(tmpgv));
3576     }
3577
3578     /* touch @F array to prevent spurious warnings 20020415 MJD */
3579     if (PL_minus_a) {
3580       (void) get_av("main::F", TRUE | GV_ADDMULTI);
3581     }
3582     /* touch @- and @+ arrays to prevent spurious warnings 20020415 MJD */
3583     (void) get_av("main::-", TRUE | GV_ADDMULTI);
3584     (void) get_av("main::+", TRUE | GV_ADDMULTI);
3585 }
3586
3587 STATIC void
3588 S_init_perllib(pTHX)
3589 {
3590     char *s;
3591     if (!PL_tainting) {
3592 #ifndef VMS
3593         s = PerlEnv_getenv("PERL5LIB");
3594         if (s)
3595             incpush(s, TRUE, TRUE);
3596         else
3597             incpush(PerlEnv_getenv("PERLLIB"), FALSE, FALSE);
3598 #else /* VMS */
3599         /* Treat PERL5?LIB as a possible search list logical name -- the
3600          * "natural" VMS idiom for a Unix path string.  We allow each
3601          * element to be a set of |-separated directories for compatibility.
3602          */
3603         char buf[256];
3604         int idx = 0;
3605         if (my_trnlnm("PERL5LIB",buf,0))
3606             do { incpush(buf,TRUE,TRUE); } while (my_trnlnm("PERL5LIB",buf,++idx));
3607         else
3608             while (my_trnlnm("PERLLIB",buf,idx++)) incpush(buf,FALSE,FALSE);
3609 #endif /* VMS */
3610     }
3611
3612 /* Use the ~-expanded versions of APPLLIB (undocumented),
3613     ARCHLIB PRIVLIB SITEARCH SITELIB VENDORARCH and VENDORLIB
3614 */
3615 #ifdef APPLLIB_EXP
3616     incpush(APPLLIB_EXP, TRUE, TRUE);
3617 #endif
3618
3619 #ifdef ARCHLIB_EXP
3620     incpush(ARCHLIB_EXP, FALSE, FALSE);
3621 #endif
3622 #ifdef MACOS_TRADITIONAL
3623     {
3624         struct stat tmpstatbuf;
3625         SV * privdir = NEWSV(55, 0);
3626         char * macperl = PerlEnv_getenv("MACPERL");
3627
3628         if (!macperl)
3629             macperl = "";
3630
3631         Perl_sv_setpvf(aTHX_ privdir, "%slib:", macperl);
3632         if (PerlLIO_stat(SvPVX(privdir), &tmpstatbuf) >= 0 && S_ISDIR(tmpstatbuf.st_mode))
3633             incpush(SvPVX(privdir), TRUE, FALSE);
3634         Perl_sv_setpvf(aTHX_ privdir, "%ssite_perl:", macperl);
3635         if (PerlLIO_stat(SvPVX(privdir), &tmpstatbuf) >= 0 && S_ISDIR(tmpstatbuf.st_mode))
3636             incpush(SvPVX(privdir), TRUE, FALSE);
3637
3638         SvREFCNT_dec(privdir);
3639     }
3640     if (!PL_tainting)
3641         incpush(":", FALSE, FALSE);
3642 #else
3643 #ifndef PRIVLIB_EXP
3644 #  define PRIVLIB_EXP "/usr/local/lib/perl5:/usr/local/lib/perl"
3645 #endif
3646 #if defined(WIN32)
3647     incpush(PRIVLIB_EXP, TRUE, FALSE);
3648 #else
3649     incpush(PRIVLIB_EXP, FALSE, FALSE);
3650 #endif
3651
3652 #ifdef SITEARCH_EXP
3653     /* sitearch is always relative to sitelib on Windows for
3654      * DLL-based path intuition to work correctly */
3655 #  if !defined(WIN32)
3656     incpush(SITEARCH_EXP, FALSE, FALSE);
3657 #  endif
3658 #endif
3659
3660 #ifdef SITELIB_EXP
3661 #  if defined(WIN32)
3662     incpush(SITELIB_EXP, TRUE, FALSE);  /* this picks up sitearch as well */
3663 #  else
3664     incpush(SITELIB_EXP, FALSE, FALSE);
3665 #  endif
3666 #endif
3667
3668 #ifdef SITELIB_STEM /* Search for version-specific dirs below here */
3669     incpush(SITELIB_STEM, FALSE, TRUE);
3670 #endif
3671
3672 #ifdef PERL_VENDORARCH_EXP
3673     /* vendorarch is always relative to vendorlib on Windows for
3674      * DLL-based path intuition to work correctly */
3675 #  if !defined(WIN32)
3676     incpush(PERL_VENDORARCH_EXP, FALSE, FALSE);
3677 #  endif
3678 #endif
3679
3680 #ifdef PERL_VENDORLIB_EXP
3681 #  if defined(WIN32)
3682     incpush(PERL_VENDORLIB_EXP, TRUE, FALSE);   /* this picks up vendorarch as well */
3683 #  else
3684     incpush(PERL_VENDORLIB_EXP, FALSE, FALSE);
3685 #  endif
3686 #endif
3687
3688 #ifdef PERL_VENDORLIB_STEM /* Search for version-specific dirs below here */
3689     incpush(PERL_VENDORLIB_STEM, FALSE, TRUE);
3690 #endif
3691
3692 #ifdef PERL_OTHERLIBDIRS
3693     incpush(PERL_OTHERLIBDIRS, TRUE, TRUE);
3694 #endif
3695
3696     if (!PL_tainting)
3697         incpush(".", FALSE, FALSE);
3698 #endif /* MACOS_TRADITIONAL */
3699 }
3700
3701 #if defined(DOSISH) || defined(EPOC)
3702 #    define PERLLIB_SEP ';'
3703 #else
3704 #  if defined(VMS)
3705 #    define PERLLIB_SEP '|'
3706 #  else
3707 #    if defined(MACOS_TRADITIONAL)
3708 #      define PERLLIB_SEP ','
3709 #    else
3710 #      define PERLLIB_SEP ':'
3711 #    endif
3712 #  endif
3713 #endif
3714 #ifndef PERLLIB_MANGLE
3715 #  define PERLLIB_MANGLE(s,n) (s)
3716 #endif
3717
3718 STATIC void
3719 S_incpush(pTHX_ char *p, int addsubdirs, int addoldvers)
3720 {
3721     SV *subdir = Nullsv;
3722
3723     if (!p || !*p)
3724         return;
3725
3726     if (addsubdirs || addoldvers) {
3727         subdir = sv_newmortal();
3728     }
3729
3730     /* Break at all separators */
3731     while (p && *p) {
3732         SV *libdir = NEWSV(55,0);
3733         char *s;
3734
3735         /* skip any consecutive separators */
3736         while ( *p == PERLLIB_SEP ) {
3737             /* Uncomment the next line for PATH semantics */
3738             /* av_push(GvAVn(PL_incgv), newSVpvn(".", 1)); */
3739             p++;
3740         }
3741
3742         if ( (s = strchr(p, PERLLIB_SEP)) != Nullch ) {
3743             sv_setpvn(libdir, PERLLIB_MANGLE(p, (STRLEN)(s - p)),
3744                       (STRLEN)(s - p));
3745             p = s + 1;
3746         }
3747         else {
3748             sv_setpv(libdir, PERLLIB_MANGLE(p, 0));
3749             p = Nullch; /* break out */
3750         }
3751 #ifdef MACOS_TRADITIONAL
3752         if (!strchr(SvPVX(libdir), ':'))
3753             sv_insert(libdir, 0, 0, ":", 1);
3754         if (SvPVX(libdir)[SvCUR(libdir)-1] != ':')
3755             sv_catpv(libdir, ":");
3756 #endif
3757
3758         /*
3759          * BEFORE pushing libdir onto @INC we may first push version- and
3760          * archname-specific sub-directories.
3761          */
3762         if (addsubdirs || addoldvers) {
3763 #ifdef PERL_INC_VERSION_LIST
3764             /* Configure terminates PERL_INC_VERSION_LIST with a NULL */
3765             const char *incverlist[] = { PERL_INC_VERSION_LIST };
3766             const char **incver;
3767 #endif
3768             struct stat tmpstatbuf;
3769 #ifdef VMS
3770             char *unix;
3771             STRLEN len;
3772
3773             if ((unix = tounixspec_ts(SvPV(libdir,len),Nullch)) != Nullch) {
3774                 len = strlen(unix);
3775                 while (unix[len-1] == '/') len--;  /* Cosmetic */
3776                 sv_usepvn(libdir,unix,len);
3777             }
3778             else
3779                 PerlIO_printf(Perl_error_log,
3780                               "Failed to unixify @INC element \"%s\"\n",
3781                               SvPV(libdir,len));
3782 #endif
3783             if (addsubdirs) {
3784 #ifdef MACOS_TRADITIONAL
3785 #define PERL_AV_SUFFIX_FMT      ""
3786 #define PERL_ARCH_FMT           "%s:"
3787 #define PERL_ARCH_FMT_PATH      PERL_FS_VER_FMT PERL_AV_SUFFIX_FMT
3788 #else
3789 #define PERL_AV_SUFFIX_FMT      "/"
3790 #define PERL_ARCH_FMT           "/%s"
3791 #define PERL_ARCH_FMT_PATH      PERL_AV_SUFFIX_FMT PERL_FS_VER_FMT
3792 #endif
3793                 /* .../version/archname if -d .../version/archname */
3794                 Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_ARCH_FMT_PATH PERL_ARCH_FMT,
3795                                 libdir,
3796                                (int)PERL_REVISION, (int)PERL_VERSION,
3797                                (int)PERL_SUBVERSION, ARCHNAME);
3798                 if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
3799                       S_ISDIR(tmpstatbuf.st_mode))
3800                     av_push(GvAVn(PL_incgv), newSVsv(subdir));
3801
3802                 /* .../version if -d .../version */
3803                 Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_ARCH_FMT_PATH, libdir,
3804                                (int)PERL_REVISION, (int)PERL_VERSION,
3805                                (int)PERL_SUBVERSION);
3806                 if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
3807                       S_ISDIR(tmpstatbuf.st_mode))
3808                     av_push(GvAVn(PL_incgv), newSVsv(subdir));
3809
3810                 /* .../archname if -d .../archname */
3811                 Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_ARCH_FMT, libdir, ARCHNAME);
3812                 if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
3813                       S_ISDIR(tmpstatbuf.st_mode))
3814                     av_push(GvAVn(PL_incgv), newSVsv(subdir));
3815             }
3816
3817 #ifdef PERL_INC_VERSION_LIST
3818             if (addoldvers) {
3819                 for (incver = incverlist; *incver; incver++) {
3820                     /* .../xxx if -d .../xxx */
3821                     Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_ARCH_FMT, libdir, *incver);
3822                     if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
3823                           S_ISDIR(tmpstatbuf.st_mode))
3824                         av_push(GvAVn(PL_incgv), newSVsv(subdir));
3825                 }
3826             }
3827 #endif
3828         }
3829
3830         /* finally push this lib directory on the end of @INC */
3831         av_push(GvAVn(PL_incgv), libdir);
3832     }
3833 }
3834
3835 #ifdef USE_5005THREADS
3836 STATIC struct perl_thread *
3837 S_init_main_thread(pTHX)
3838 {
3839 #if !defined(PERL_IMPLICIT_CONTEXT)
3840     struct perl_thread *thr;
3841 #endif
3842     XPV *xpv;
3843
3844     Newz(53, thr, 1, struct perl_thread);
3845     PL_curcop = &PL_compiling;
3846     thr->interp = PERL_GET_INTERP;
3847     thr->cvcache = newHV();
3848     thr->threadsv = newAV();
3849     /* thr->threadsvp is set when find_threadsv is called */
3850     thr->specific = newAV();
3851     thr->flags = THRf_R_JOINABLE;
3852     MUTEX_INIT(&thr->mutex);
3853     /* Handcraft thrsv similarly to mess_sv */
3854     New(53, PL_thrsv, 1, SV);
3855     Newz(53, xpv, 1, XPV);
3856     SvFLAGS(PL_thrsv) = SVt_PV;
3857     SvANY(PL_thrsv) = (void*)xpv;
3858     SvREFCNT(PL_thrsv) = 1 << 30;       /* practically infinite */
3859     SvPVX(PL_thrsv) = (char*)thr;
3860     SvCUR_set(PL_thrsv, sizeof(thr));
3861     SvLEN_set(PL_thrsv, sizeof(thr));
3862     *SvEND(PL_thrsv) = '\0';    /* in the trailing_nul field */
3863     thr->oursv = PL_thrsv;
3864     PL_chopset = " \n-";
3865     PL_dumpindent = 4;
3866
3867     MUTEX_LOCK(&PL_threads_mutex);
3868     PL_nthreads++;
3869     thr->tid = 0;
3870     thr->next = thr;
3871     thr->prev = thr;
3872     thr->thr_done = 0;
3873     MUTEX_UNLOCK(&PL_threads_mutex);
3874
3875 #ifdef HAVE_THREAD_INTERN
3876     Perl_init_thread_intern(thr);
3877 #endif
3878
3879 #ifdef SET_THREAD_SELF
3880     SET_THREAD_SELF(thr);
3881 #else
3882     thr->self = pthread_self();
3883 #endif /* SET_THREAD_SELF */
3884     PERL_SET_THX(thr);
3885
3886     /*
3887      * These must come after the thread self setting
3888      * because sv_setpvn does SvTAINT and the taint
3889      * fields thread selfness being set.
3890      */
3891     PL_toptarget = NEWSV(0,0);
3892     sv_upgrade(PL_toptarget, SVt_PVFM);
3893     sv_setpvn(PL_toptarget, "", 0);
3894     PL_bodytarget = NEWSV(0,0);
3895     sv_upgrade(PL_bodytarget, SVt_PVFM);
3896     sv_setpvn(PL_bodytarget, "", 0);
3897     PL_formtarget = PL_bodytarget;
3898     thr->errsv = newSVpvn("", 0);
3899     (void) find_threadsv("@");  /* Ensure $@ is initialised early */
3900
3901     PL_maxscream = -1;
3902     PL_peepp = MEMBER_TO_FPTR(Perl_peep);
3903     PL_regcompp = MEMBER_TO_FPTR(Perl_pregcomp);
3904     PL_regexecp = MEMBER_TO_FPTR(Perl_regexec_flags);
3905     PL_regint_start = MEMBER_TO_FPTR(Perl_re_intuit_start);
3906     PL_regint_string = MEMBER_TO_FPTR(Perl_re_intuit_string);
3907     PL_regfree = MEMBER_TO_FPTR(Perl_pregfree);
3908     PL_regindent = 0;
3909     PL_reginterp_cnt = 0;
3910
3911     return thr;
3912 }
3913 #endif /* USE_5005THREADS */
3914
3915 void
3916 Perl_call_list(pTHX_ I32 oldscope, AV *paramList)
3917 {
3918     SV *atsv;
3919     line_t oldline = CopLINE(PL_curcop);
3920     CV *cv;
3921     STRLEN len;
3922     int ret;
3923     dJMPENV;
3924
3925     while (AvFILL(paramList) >= 0) {
3926         cv = (CV*)av_shift(paramList);
3927         if (PL_savebegin && (paramList == PL_beginav)) {
3928                 /* save PL_beginav for compiler */
3929             if (! PL_beginav_save)
3930                 PL_beginav_save = newAV();
3931             av_push(PL_beginav_save, (SV*)cv);
3932         } else {
3933             SAVEFREESV(cv);
3934         }
3935 #ifdef PERL_FLEXIBLE_EXCEPTIONS
3936         CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_vcall_list_body), cv);
3937 #else
3938         JMPENV_PUSH(ret);
3939 #endif
3940         switch (ret) {
3941         case 0:
3942 #ifndef PERL_FLEXIBLE_EXCEPTIONS
3943             call_list_body(cv);
3944 #endif
3945             atsv = ERRSV;
3946             (void)SvPV(atsv, len);
3947             if (len) {
3948                 STRLEN n_a;
3949                 PL_curcop = &PL_compiling;
3950                 CopLINE_set(PL_curcop, oldline);
3951                 if (paramList == PL_beginav)
3952                     sv_catpv(atsv, "BEGIN failed--compilation aborted");
3953                 else
3954                     Perl_sv_catpvf(aTHX_ atsv,
3955                                    "%s failed--call queue aborted",
3956                                    paramList == PL_checkav ? "CHECK"
3957                                    : paramList == PL_initav ? "INIT"
3958                                    : "END");
3959                 while (PL_scopestack_ix > oldscope)
3960                     LEAVE;
3961                 JMPENV_POP;
3962                 Perl_croak(aTHX_ "%s", SvPVx(atsv, n_a));
3963             }
3964             break;
3965         case 1:
3966             STATUS_ALL_FAILURE;
3967             /* FALL THROUGH */
3968         case 2:
3969             /* my_exit() was called */
3970             while (PL_scopestack_ix > oldscope)
3971                 LEAVE;
3972             FREETMPS;
3973             PL_curstash = PL_defstash;
3974             PL_curcop = &PL_compiling;
3975             CopLINE_set(PL_curcop, oldline);
3976             JMPENV_POP;
3977             if (PL_statusvalue && !(PL_exit_flags & PERL_EXIT_EXPECTED)) {
3978                 if (paramList == PL_beginav)
3979                     Perl_croak(aTHX_ "BEGIN failed--compilation aborted");
3980                 else
3981                     Perl_croak(aTHX_ "%s failed--call queue aborted",
3982                                paramList == PL_checkav ? "CHECK"
3983                                : paramList == PL_initav ? "INIT"
3984                                : "END");
3985             }
3986             my_exit_jump();
3987             /* NOTREACHED */
3988         case 3:
3989             if (PL_restartop) {
3990                 PL_curcop = &PL_compiling;
3991                 CopLINE_set(PL_curcop, oldline);
3992                 JMPENV_JUMP(3);
3993             }
3994             PerlIO_printf(Perl_error_log, "panic: restartop\n");
3995             FREETMPS;
3996             break;
3997         }
3998         JMPENV_POP;
3999     }
4000 }
4001
4002 #ifdef PERL_FLEXIBLE_EXCEPTIONS
4003 STATIC void *
4004 S_vcall_list_body(pTHX_ va_list args)
4005 {
4006     CV *cv = va_arg(args, CV*);
4007     return call_list_body(cv);
4008 }
4009 #endif
4010
4011 STATIC void *
4012 S_call_list_body(pTHX_ CV *cv)
4013 {
4014     PUSHMARK(PL_stack_sp);
4015     call_sv((SV*)cv, G_EVAL|G_DISCARD);
4016     return NULL;
4017 }
4018
4019 void
4020 Perl_my_exit(pTHX_ U32 status)
4021 {
4022     DEBUG_S(PerlIO_printf(Perl_debug_log, "my_exit: thread %p, status %lu\n",
4023                           thr, (unsigned long) status));
4024     switch (status) {
4025     case 0:
4026         STATUS_ALL_SUCCESS;
4027         break;
4028     case 1:
4029         STATUS_ALL_FAILURE;
4030         break;
4031     default:
4032         STATUS_NATIVE_SET(status);
4033         break;
4034     }
4035     my_exit_jump();
4036 }
4037
4038 void
4039 Perl_my_failure_exit(pTHX)
4040 {
4041 #ifdef VMS
4042     if (vaxc$errno & 1) {
4043         if (STATUS_NATIVE & 1)          /* fortuitiously includes "-1" */
4044             STATUS_NATIVE_SET(44);
4045     }
4046     else {
4047         if (!vaxc$errno && errno)       /* unlikely */
4048             STATUS_NATIVE_SET(44);
4049         else
4050             STATUS_NATIVE_SET(vaxc$errno);
4051     }
4052 #else
4053     int exitstatus;
4054     if (errno & 255)
4055         STATUS_POSIX_SET(errno);
4056     else {
4057         exitstatus = STATUS_POSIX >> 8;
4058         if (exitstatus & 255)
4059             STATUS_POSIX_SET(exitstatus);
4060         else
4061             STATUS_POSIX_SET(255);
4062     }
4063 #endif
4064     my_exit_jump();
4065 }
4066
4067 STATIC void
4068 S_my_exit_jump(pTHX)
4069 {
4070     register PERL_CONTEXT *cx;
4071     I32 gimme;
4072     SV **newsp;
4073
4074     if (PL_e_script) {
4075         SvREFCNT_dec(PL_e_script);
4076         PL_e_script = Nullsv;
4077     }
4078
4079     POPSTACK_TO(PL_mainstack);
4080     if (cxstack_ix >= 0) {
4081         if (cxstack_ix > 0)
4082             dounwind(0);
4083         POPBLOCK(cx,PL_curpm);
4084         LEAVE;
4085     }
4086
4087     JMPENV_JUMP(2);
4088 }
4089
4090 static I32
4091 read_e_script(pTHX_ int idx, SV *buf_sv, int maxlen)
4092 {
4093     char *p, *nl;
4094     p  = SvPVX(PL_e_script);
4095     nl = strchr(p, '\n');
4096     nl = (nl) ? nl+1 : SvEND(PL_e_script);
4097     if (nl-p == 0) {
4098         filter_del(read_e_script);
4099         return 0;
4100     }
4101     sv_catpvn(buf_sv, p, nl-p);
4102     sv_chop(PL_e_script, nl);
4103     return 1;
4104 }