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