perl.c

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