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