perl.c

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