perl.c

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