perl.c

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