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