perl.c

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