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