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