perl.c

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