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