perl.c

   1 /*    perl.c
   2  *
   3  *    Copyright (C) 1993, 1994, 1995, 1996, 1997, 1998, 1999,
   4  *    2000, 2001, 2002, 2003, by Larry Wall and others
   5  *
   6  *    You may distribute under the terms of either the GNU General Public
   7  *    License or the Artistic License, as specified in the README file.
   8  *
   9  */
  10
  11 /*
  12  * "A ship then new they built for him/of mithril and of elven glass" --Bilbo
  13  */
  14
  15 #include "EXTERN.h"
  16 #define PERL_IN_PERL_C
  17 #include "perl.h"
  18 #include "patchlevel.h"                 /* for local_patches */
  19
  20 #ifdef NETWARE
  21 #include "nwutil.h"
  22 char *nw_get_sitelib(const char *pl);
  23 #endif
  24
  25 /* XXX If this causes problems, set i_unistd=undef in the hint file.  */
  26 #ifdef I_UNISTD
  27 #include <unistd.h>
  28 #endif
  29
  30 #ifdef __BEOS__
  31 #  define HZ 1000000
  32 #endif
  33
  34 #ifndef HZ
  35 #  ifdef CLK_TCK
  36 #    define HZ CLK_TCK
  37 #  else
  38 #    define HZ 60
  39 #  endif
  40 #endif
  41
  42 #if !defined(STANDARD_C) && !defined(HAS_GETENV_PROTOTYPE) && !defined(PERL_MICRO)
  43 char *getenv (char *); /* Usually in <stdlib.h> */
  44 #endif
  45
  46 static I32 read_e_script(pTHX_ int idx, SV *buf_sv, int maxlen);
  47
  48 #ifdef IAMSUID
  49 #ifndef DOSUID
  50 #define DOSUID
  51 #endif
  52 #endif
  53
  54 #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
  55 #ifdef DOSUID
  56 #undef DOSUID
  57 #endif
  58 #endif
  59
  60 #if defined(USE_ITHREADS)
  61 #  define INIT_TLS_AND_INTERP \
  62     STMT_START {                                \
  63         if (!PL_curinterp) {                    \
  64             PERL_SET_INTERP(my_perl);           \
  65             INIT_THREADS;                       \
  66             ALLOC_THREAD_KEY;                   \
  67             PERL_SET_THX(my_perl);              \
  68             OP_REFCNT_INIT;                     \
  69             MUTEX_INIT(&PL_dollarzero_mutex);   \
  70         }                                       \
  71         else {                                  \
  72             PERL_SET_THX(my_perl);              \
  73         }                                       \
  74     } STMT_END
  75 #else
  76 #  define INIT_TLS_AND_INTERP \
  77     STMT_START {                                \
  78         if (!PL_curinterp) {                    \
  79             PERL_SET_INTERP(my_perl);           \
  80         }                                       \
  81         PERL_SET_THX(my_perl);                  \
  82     } STMT_END
  83 #  endif
  84
  85 #ifdef PERL_IMPLICIT_SYS
  86 PerlInterpreter *
  87 perl_alloc_using(struct IPerlMem* ipM, struct IPerlMem* ipMS,
  88                  struct IPerlMem* ipMP, struct IPerlEnv* ipE,
  89                  struct IPerlStdIO* ipStd, struct IPerlLIO* ipLIO,
  90                  struct IPerlDir* ipD, struct IPerlSock* ipS,
  91                  struct IPerlProc* ipP)
  92 {
  93     PerlInterpreter *my_perl;
  94     /* New() needs interpreter, so call malloc() instead */
  95     my_perl = (PerlInterpreter*)(*ipM->pMalloc)(ipM, sizeof(PerlInterpreter));
  96     INIT_TLS_AND_INTERP;
  97     Zero(my_perl, 1, PerlInterpreter);
  98     PL_Mem = ipM;
  99     PL_MemShared = ipMS;
 100     PL_MemParse = ipMP;
 101     PL_Env = ipE;
 102     PL_StdIO = ipStd;
 103     PL_LIO = ipLIO;
 104     PL_Dir = ipD;
 105     PL_Sock = ipS;
 106     PL_Proc = ipP;
 107
 108     return my_perl;
 109 }
 110 #else
 111
 112 /*
 113 =head1 Embedding Functions
 114
 115 =for apidoc perl_alloc
 116
 117 Allocates a new Perl interpreter.  See L<perlembed>.
 118
 119 =cut
 120 */
 121
 122 PerlInterpreter *
 123 perl_alloc(void)
 124 {
 125     PerlInterpreter *my_perl;
 126 #ifdef USE_5005THREADS
 127     dTHX;
 128 #endif
 129
 130     /* New() needs interpreter, so call malloc() instead */
 131     my_perl = (PerlInterpreter*)PerlMem_malloc(sizeof(PerlInterpreter));
 132
 133     INIT_TLS_AND_INTERP;
 134     Zero(my_perl, 1, PerlInterpreter);
 135     return my_perl;
 136 }
 137 #endif /* PERL_IMPLICIT_SYS */
 138
 139 /*
 140 =for apidoc perl_construct
 141
 142 Initializes a new Perl interpreter.  See L<perlembed>.
 143
 144 =cut
 145 */
 146
 147 void
 148 perl_construct(pTHXx)
 149 {
 150 #ifdef MULTIPLICITY
 151     init_interp();
 152     PL_perl_destruct_level = 1;
 153 #else
 154    if (PL_perl_destruct_level > 0)
 155        init_interp();
 156 #endif
 157    /* Init the real globals (and main thread)? */
 158     if (!PL_linestr) {
 159 #ifdef PERL_FLEXIBLE_EXCEPTIONS
 160         PL_protect = MEMBER_TO_FPTR(Perl_default_protect); /* for exceptions */
 161 #endif
 162
 163         PL_curcop = &PL_compiling;      /* needed by ckWARN, right away */
 164
 165         PL_linestr = NEWSV(65,79);
 166         sv_upgrade(PL_linestr,SVt_PVIV);
 167
 168         if (!SvREADONLY(&PL_sv_undef)) {
 169             /* set read-only and try to insure than we wont see REFCNT==0
 170                very often */
 171
 172             SvREADONLY_on(&PL_sv_undef);
 173             SvREFCNT(&PL_sv_undef) = (~(U32)0)/2;
 174
 175             sv_setpv(&PL_sv_no,PL_No);
 176             SvNV(&PL_sv_no);
 177             SvREADONLY_on(&PL_sv_no);
 178             SvREFCNT(&PL_sv_no) = (~(U32)0)/2;
 179
 180             sv_setpv(&PL_sv_yes,PL_Yes);
 181             SvNV(&PL_sv_yes);
 182             SvREADONLY_on(&PL_sv_yes);
 183             SvREFCNT(&PL_sv_yes) = (~(U32)0)/2;
 184
 185             SvREADONLY_on(&PL_sv_placeholder);
 186             SvREFCNT(&PL_sv_placeholder) = (~(U32)0)/2;
 187         }
 188
 189         PL_sighandlerp = Perl_sighandler;
 190         PL_pidstatus = newHV();
 191     }
 192
 193     PL_rs = newSVpvn("\n", 1);
 194
 195     init_stacks();
 196
 197     init_ids();
 198     PL_lex_state = LEX_NOTPARSING;
 199
 200     JMPENV_BOOTSTRAP;
 201     STATUS_ALL_SUCCESS;
 202
 203     init_i18nl10n(1);
 204     SET_NUMERIC_STANDARD();
 205
 206     {
 207         U8 *s;
 208         PL_patchlevel = NEWSV(0,4);
 209         (void)SvUPGRADE(PL_patchlevel, SVt_PVNV);
 210         if (PERL_REVISION > 127 || PERL_VERSION > 127 || PERL_SUBVERSION > 127)
 211             SvGROW(PL_patchlevel, UTF8_MAXLEN*3+1);
 212         s = (U8*)SvPVX(PL_patchlevel);
 213         /* Build version strings using "native" characters */
 214         s = uvchr_to_utf8(s, (UV)PERL_REVISION);
 215         s = uvchr_to_utf8(s, (UV)PERL_VERSION);
 216         s = uvchr_to_utf8(s, (UV)PERL_SUBVERSION);
 217         *s = '\0';
 218         SvCUR_set(PL_patchlevel, s - (U8*)SvPVX(PL_patchlevel));
 219         SvPOK_on(PL_patchlevel);
 220         SvNVX(PL_patchlevel) = (NV)PERL_REVISION +
 221                               ((NV)PERL_VERSION / (NV)1000) +
 222                               ((NV)PERL_SUBVERSION / (NV)1000000);
 223         SvNOK_on(PL_patchlevel);        /* dual valued */
 224         SvUTF8_on(PL_patchlevel);
 225         SvREADONLY_on(PL_patchlevel);
 226     }
 227
 228 #if defined(LOCAL_PATCH_COUNT)
 229     PL_localpatches = local_patches;    /* For possible -v */
 230 #endif
 231
 232 #ifdef HAVE_INTERP_INTERN
 233     sys_intern_init();
 234 #endif
 235
 236     PerlIO_init(aTHX);                  /* Hook to IO system */
 237
 238     PL_fdpid = newAV();                 /* for remembering popen pids by fd */
 239     PL_modglobal = newHV();             /* pointers to per-interpreter module globals */
 240     PL_errors = newSVpvn("",0);
 241     sv_setpvn(PERL_DEBUG_PAD(0), "", 0);        /* For regex debugging. */
 242     sv_setpvn(PERL_DEBUG_PAD(1), "", 0);        /* ext/re needs these */
 243     sv_setpvn(PERL_DEBUG_PAD(2), "", 0);        /* even without DEBUGGING. */
 244 #ifdef USE_ITHREADS
 245     PL_regex_padav = newAV();
 246     av_push(PL_regex_padav,(SV*)newAV());    /* First entry is an array of empty elements */
 247     PL_regex_pad = AvARRAY(PL_regex_padav);
 248 #endif
 249 #ifdef USE_REENTRANT_API
 250     Perl_reentrant_init(aTHX);
 251 #endif
 252
 253     /* Note that strtab is a rather special HV.  Assumptions are made
 254        about not iterating on it, and not adding tie magic to it.
 255        It is properly deallocated in perl_destruct() */
 256     PL_strtab = newHV();
 257
 258     HvSHAREKEYS_off(PL_strtab);                 /* mandatory */
 259     hv_ksplit(PL_strtab, 512);
 260
 261 #if defined(__DYNAMIC__) && (defined(NeXT) || defined(__NeXT__))
 262     _dyld_lookup_and_bind
 263         ("__environ", (unsigned long *) &environ_pointer, NULL);
 264 #endif /* environ */
 265
 266 #ifdef  USE_ENVIRON_ARRAY
 267     PL_origenviron = environ;
 268 #endif
 269
 270     /* Use sysconf(_SC_CLK_TCK) if available, if not
 271      * available or if the sysconf() fails, use the HZ. */
 272 #if defined(HAS_SYSCONF) && defined(_SC_CLK_TCK)
 273     PL_clocktick = sysconf(_SC_CLK_TCK);
 274     if (PL_clocktick <= 0)
 275 #endif
 276          PL_clocktick = HZ;
 277
 278     PL_stashcache = newHV();
 279
 280     ENTER;
 281 }
 282
 283 /*
 284 =for apidoc nothreadhook
 285
 286 Stub that provides thread hook for perl_destruct when there are
 287 no threads.
 288
 289 =cut
 290 */
 291
 292 int
 293 Perl_nothreadhook(pTHX)
 294 {
 295     return 0;
 296 }
 297
 298 /*
 299 =for apidoc perl_destruct
 300
 301 Shuts down a Perl interpreter.  See L<perlembed>.
 302
 303 =cut
 304 */
 305
 306 int
 307 perl_destruct(pTHXx)
 308 {
 309     volatile int destruct_level;  /* 0=none, 1=full, 2=full with checks */
 310     HV *hv;
 311 #ifdef USE_5005THREADS
 312     dTHX;
 313 #endif /* USE_5005THREADS */
 314
 315     /* wait for all pseudo-forked children to finish */
 316     PERL_WAIT_FOR_CHILDREN;
 317
 318     destruct_level = PL_perl_destruct_level;
 319 #ifdef DEBUGGING
 320     {
 321         char *s;
 322         if ((s = PerlEnv_getenv("PERL_DESTRUCT_LEVEL"))) {
 323             int i = atoi(s);
 324             if (destruct_level < i)
 325                 destruct_level = i;
 326         }
 327     }
 328 #endif
 329
 330
 331     if(PL_exit_flags & PERL_EXIT_DESTRUCT_END) {
 332         dJMPENV;
 333         int x = 0;
 334
 335         JMPENV_PUSH(x);
 336         if (PL_endav && !PL_minus_c)
 337             call_list(PL_scopestack_ix, PL_endav);
 338         JMPENV_POP;
 339     }
 340     LEAVE;
 341     FREETMPS;
 342
 343     /* Need to flush since END blocks can produce output */
 344     my_fflush_all();
 345
 346     if (CALL_FPTR(PL_threadhook)(aTHX)) {
 347         /* Threads hook has vetoed further cleanup */
 348         return STATUS_NATIVE_EXPORT;
 349     }
 350
 351     /* We must account for everything.  */
 352
 353     /* Destroy the main CV and syntax tree */
 354     if (PL_main_root) {
 355         op_free(PL_main_root);
 356         PL_main_root = Nullop;
 357     }
 358     PL_curcop = &PL_compiling;
 359     PL_main_start = Nullop;
 360     SvREFCNT_dec(PL_main_cv);
 361     PL_main_cv = Nullcv;
 362     PL_dirty = TRUE;
 363
 364     /* Tell PerlIO we are about to tear things apart in case
 365        we have layers which are using resources that should
 366        be cleaned up now.
 367      */
 368
 369     PerlIO_destruct(aTHX);
 370
 371     if (PL_sv_objcount) {
 372         /*
 373          * Try to destruct global references.  We do this first so that the
 374          * destructors and destructees still exist.  Some sv's might remain.
 375          * Non-referenced objects are on their own.
 376          */
 377         sv_clean_objs();
 378     }
 379
 380     /* unhook hooks which will soon be, or use, destroyed data */
 381     SvREFCNT_dec(PL_warnhook);
 382     PL_warnhook = Nullsv;
 383     SvREFCNT_dec(PL_diehook);
 384     PL_diehook = Nullsv;
 385
 386     /* call exit list functions */
 387     while (PL_exitlistlen-- > 0)
 388         PL_exitlist[PL_exitlistlen].fn(aTHX_ PL_exitlist[PL_exitlistlen].ptr);
 389
 390     Safefree(PL_exitlist);
 391
 392     PL_exitlist = NULL;
 393     PL_exitlistlen = 0;
 394
 395     if (destruct_level == 0){
 396
 397         DEBUG_P(debprofdump());
 398
 399 #if defined(PERLIO_LAYERS)
 400         /* No more IO - including error messages ! */
 401         PerlIO_cleanup(aTHX);
 402 #endif
 403
 404         /* The exit() function will do everything that needs doing. */
 405         return STATUS_NATIVE_EXPORT;
 406     }
 407
 408     /* jettison our possibly duplicated environment */
 409     /* if PERL_USE_SAFE_PUTENV is defined environ will not have been copied
 410      * so we certainly shouldn't free it here
 411      */
 412 #if defined(USE_ENVIRON_ARRAY) && !defined(PERL_USE_SAFE_PUTENV)
 413     if (environ != PL_origenviron
 414 #ifdef USE_ITHREADS
 415         /* only main thread can free environ[0] contents */
 416         && PL_curinterp == aTHX
 417 #endif
 418         )
 419     {
 420         I32 i;
 421
 422         for (i = 0; environ[i]; i++)
 423             safesysfree(environ[i]);
 424
 425         /* Must use safesysfree() when working with environ. */
 426         safesysfree(environ);
 427
 428         environ = PL_origenviron;
 429     }
 430 #endif
 431
 432 #ifdef USE_ITHREADS
 433     /* the syntax tree is shared between clones
 434      * so op_free(PL_main_root) only ReREFCNT_dec's
 435      * REGEXPs in the parent interpreter
 436      * we need to manually ReREFCNT_dec for the clones
 437      */
 438     {
 439         I32 i = AvFILLp(PL_regex_padav) + 1;
 440         SV **ary = AvARRAY(PL_regex_padav);
 441
 442         while (i) {
 443             SV *resv = ary[--i];
 444             REGEXP *re = INT2PTR(REGEXP *,SvIVX(resv));
 445
 446             if (SvFLAGS(resv) & SVf_BREAK) {
 447                 /* this is PL_reg_curpm, already freed
 448                  * flag is set in regexec.c:S_regtry
 449                  */
 450                 SvFLAGS(resv) &= ~SVf_BREAK;
 451             }
 452             else if(SvREPADTMP(resv)) {
 453               SvREPADTMP_off(resv);
 454             }
 455             else {
 456                 ReREFCNT_dec(re);
 457             }
 458         }
 459     }
 460     SvREFCNT_dec(PL_regex_padav);
 461     PL_regex_padav = Nullav;
 462     PL_regex_pad = NULL;
 463 #endif
 464
 465     SvREFCNT_dec((SV*) PL_stashcache);
 466     PL_stashcache = NULL;
 467
 468     /* loosen bonds of global variables */
 469
 470     if(PL_rsfp) {
 471         (void)PerlIO_close(PL_rsfp);
 472         PL_rsfp = Nullfp;
 473     }
 474
 475     /* Filters for program text */
 476     SvREFCNT_dec(PL_rsfp_filters);
 477     PL_rsfp_filters = Nullav;
 478
 479     /* switches */
 480     PL_preprocess   = FALSE;
 481     PL_minus_n      = FALSE;
 482     PL_minus_p      = FALSE;
 483     PL_minus_l      = FALSE;
 484     PL_minus_a      = FALSE;
 485     PL_minus_F      = FALSE;
 486     PL_doswitches   = FALSE;
 487     PL_dowarn       = G_WARN_OFF;
 488     PL_doextract    = FALSE;
 489     PL_sawampersand = FALSE;    /* must save all match strings */
 490     PL_unsafe       = FALSE;
 491
 492     Safefree(PL_inplace);
 493     PL_inplace = Nullch;
 494     SvREFCNT_dec(PL_patchlevel);
 495
 496     if (PL_e_script) {
 497         SvREFCNT_dec(PL_e_script);
 498         PL_e_script = Nullsv;
 499     }
 500
 501     /* magical thingies */
 502
 503     SvREFCNT_dec(PL_ofs_sv);    /* $, */
 504     PL_ofs_sv = Nullsv;
 505
 506     SvREFCNT_dec(PL_ors_sv);    /* $\ */
 507     PL_ors_sv = Nullsv;
 508
 509     SvREFCNT_dec(PL_rs);        /* $/ */
 510     PL_rs = Nullsv;
 511
 512     PL_multiline = 0;           /* $* */
 513     Safefree(PL_osname);        /* $^O */
 514     PL_osname = Nullch;
 515
 516     SvREFCNT_dec(PL_statname);
 517     PL_statname = Nullsv;
 518     PL_statgv = Nullgv;
 519
 520     /* defgv, aka *_ should be taken care of elsewhere */
 521
 522     /* clean up after study() */
 523     SvREFCNT_dec(PL_lastscream);
 524     PL_lastscream = Nullsv;
 525     Safefree(PL_screamfirst);
 526     PL_screamfirst = 0;
 527     Safefree(PL_screamnext);
 528     PL_screamnext  = 0;
 529
 530     /* float buffer */
 531     Safefree(PL_efloatbuf);
 532     PL_efloatbuf = Nullch;
 533     PL_efloatsize = 0;
 534
 535     /* startup and shutdown function lists */
 536     SvREFCNT_dec(PL_beginav);
 537     SvREFCNT_dec(PL_beginav_save);
 538     SvREFCNT_dec(PL_endav);
 539     SvREFCNT_dec(PL_checkav);
 540     SvREFCNT_dec(PL_checkav_save);
 541     SvREFCNT_dec(PL_initav);
 542     PL_beginav = Nullav;
 543     PL_beginav_save = Nullav;
 544     PL_endav = Nullav;
 545     PL_checkav = Nullav;
 546     PL_checkav_save = Nullav;
 547     PL_initav = Nullav;
 548
 549     /* shortcuts just get cleared */
 550     PL_envgv = Nullgv;
 551     PL_incgv = Nullgv;
 552     PL_hintgv = Nullgv;
 553     PL_errgv = Nullgv;
 554     PL_argvgv = Nullgv;
 555     PL_argvoutgv = Nullgv;
 556     PL_stdingv = Nullgv;
 557     PL_stderrgv = Nullgv;
 558     PL_last_in_gv = Nullgv;
 559     PL_replgv = Nullgv;
 560     PL_debstash = Nullhv;
 561
 562     /* reset so print() ends up where we expect */
 563     setdefout(Nullgv);
 564
 565     SvREFCNT_dec(PL_argvout_stack);
 566     PL_argvout_stack = Nullav;
 567
 568     SvREFCNT_dec(PL_modglobal);
 569     PL_modglobal = Nullhv;
 570     SvREFCNT_dec(PL_preambleav);
 571     PL_preambleav = Nullav;
 572     SvREFCNT_dec(PL_subname);
 573     PL_subname = Nullsv;
 574     SvREFCNT_dec(PL_linestr);
 575     PL_linestr = Nullsv;
 576     SvREFCNT_dec(PL_pidstatus);
 577     PL_pidstatus = Nullhv;
 578     SvREFCNT_dec(PL_toptarget);
 579     PL_toptarget = Nullsv;
 580     SvREFCNT_dec(PL_bodytarget);
 581     PL_bodytarget = Nullsv;
 582     PL_formtarget = Nullsv;
 583
 584     /* free locale stuff */
 585 #ifdef USE_LOCALE_COLLATE
 586     Safefree(PL_collation_name);
 587     PL_collation_name = Nullch;
 588 #endif
 589
 590 #ifdef USE_LOCALE_NUMERIC
 591     Safefree(PL_numeric_name);
 592     PL_numeric_name = Nullch;
 593     SvREFCNT_dec(PL_numeric_radix_sv);
 594 #endif
 595
 596     /* clear utf8 character classes */
 597     SvREFCNT_dec(PL_utf8_alnum);
 598     SvREFCNT_dec(PL_utf8_alnumc);
 599     SvREFCNT_dec(PL_utf8_ascii);
 600     SvREFCNT_dec(PL_utf8_alpha);
 601     SvREFCNT_dec(PL_utf8_space);
 602     SvREFCNT_dec(PL_utf8_cntrl);
 603     SvREFCNT_dec(PL_utf8_graph);
 604     SvREFCNT_dec(PL_utf8_digit);
 605     SvREFCNT_dec(PL_utf8_upper);
 606     SvREFCNT_dec(PL_utf8_lower);
 607     SvREFCNT_dec(PL_utf8_print);
 608     SvREFCNT_dec(PL_utf8_punct);
 609     SvREFCNT_dec(PL_utf8_xdigit);
 610     SvREFCNT_dec(PL_utf8_mark);
 611     SvREFCNT_dec(PL_utf8_toupper);
 612     SvREFCNT_dec(PL_utf8_totitle);
 613     SvREFCNT_dec(PL_utf8_tolower);
 614     SvREFCNT_dec(PL_utf8_tofold);
 615     SvREFCNT_dec(PL_utf8_idstart);
 616     SvREFCNT_dec(PL_utf8_idcont);
 617     PL_utf8_alnum       = Nullsv;
 618     PL_utf8_alnumc      = Nullsv;
 619     PL_utf8_ascii       = Nullsv;
 620     PL_utf8_alpha       = Nullsv;
 621     PL_utf8_space       = Nullsv;
 622     PL_utf8_cntrl       = Nullsv;
 623     PL_utf8_graph       = Nullsv;
 624     PL_utf8_digit       = Nullsv;
 625     PL_utf8_upper       = Nullsv;
 626     PL_utf8_lower       = Nullsv;
 627     PL_utf8_print       = Nullsv;
 628     PL_utf8_punct       = Nullsv;
 629     PL_utf8_xdigit      = Nullsv;
 630     PL_utf8_mark        = Nullsv;
 631     PL_utf8_toupper     = Nullsv;
 632     PL_utf8_totitle     = Nullsv;
 633     PL_utf8_tolower     = Nullsv;
 634     PL_utf8_tofold      = Nullsv;
 635     PL_utf8_idstart     = Nullsv;
 636     PL_utf8_idcont      = Nullsv;
 637
 638     if (!specialWARN(PL_compiling.cop_warnings))
 639         SvREFCNT_dec(PL_compiling.cop_warnings);
 640     PL_compiling.cop_warnings = Nullsv;
 641     if (!specialCopIO(PL_compiling.cop_io))
 642         SvREFCNT_dec(PL_compiling.cop_io);
 643     PL_compiling.cop_io = Nullsv;
 644     CopFILE_free(&PL_compiling);
 645     CopSTASH_free(&PL_compiling);
 646
 647     /* Prepare to destruct main symbol table.  */
 648
 649     hv = PL_defstash;
 650     PL_defstash = 0;
 651     SvREFCNT_dec(hv);
 652     SvREFCNT_dec(PL_curstname);
 653     PL_curstname = Nullsv;
 654
 655     /* clear queued errors */
 656     SvREFCNT_dec(PL_errors);
 657     PL_errors = Nullsv;
 658
 659     FREETMPS;
 660     if (destruct_level >= 2 && ckWARN_d(WARN_INTERNAL)) {
 661         if (PL_scopestack_ix != 0)
 662             Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
 663                  "Unbalanced scopes: %ld more ENTERs than LEAVEs\n",
 664                  (long)PL_scopestack_ix);
 665         if (PL_savestack_ix != 0)
 666             Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
 667                  "Unbalanced saves: %ld more saves than restores\n",
 668                  (long)PL_savestack_ix);
 669         if (PL_tmps_floor != -1)
 670             Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Unbalanced tmps: %ld more allocs than frees\n",
 671                  (long)PL_tmps_floor + 1);
 672         if (cxstack_ix != -1)
 673             Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Unbalanced context: %ld more PUSHes than POPs\n",
 674                  (long)cxstack_ix + 1);
 675     }
 676
 677     /* Now absolutely destruct everything, somehow or other, loops or no. */
 678     SvFLAGS(PL_fdpid) |= SVTYPEMASK;            /* don't clean out pid table now */
 679     SvFLAGS(PL_strtab) |= SVTYPEMASK;           /* don't clean out strtab now */
 680
 681     /* the 2 is for PL_fdpid and PL_strtab */
 682     while (PL_sv_count > 2 && sv_clean_all())
 683         ;
 684
 685     SvFLAGS(PL_fdpid) &= ~SVTYPEMASK;
 686     SvFLAGS(PL_fdpid) |= SVt_PVAV;
 687     SvFLAGS(PL_strtab) &= ~SVTYPEMASK;
 688     SvFLAGS(PL_strtab) |= SVt_PVHV;
 689
 690     AvREAL_off(PL_fdpid);               /* no surviving entries */
 691     SvREFCNT_dec(PL_fdpid);             /* needed in io_close() */
 692     PL_fdpid = Nullav;
 693
 694 #ifdef HAVE_INTERP_INTERN
 695     sys_intern_clear();
 696 #endif
 697
 698     /* Destruct the global string table. */
 699     {
 700         /* Yell and reset the HeVAL() slots that are still holding refcounts,
 701          * so that sv_free() won't fail on them.
 702          */
 703         I32 riter;
 704         I32 max;
 705         HE *hent;
 706         HE **array;
 707
 708         riter = 0;
 709         max = HvMAX(PL_strtab);
 710         array = HvARRAY(PL_strtab);
 711         hent = array[0];
 712         for (;;) {
 713             if (hent && ckWARN_d(WARN_INTERNAL)) {
 714                 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
 715                      "Unbalanced string table refcount: (%d) for \"%s\"",
 716                      HeVAL(hent) - Nullsv, HeKEY(hent));
 717                 HeVAL(hent) = Nullsv;
 718                 hent = HeNEXT(hent);
 719             }
 720             if (!hent) {
 721                 if (++riter > max)
 722                     break;
 723                 hent = array[riter];
 724             }
 725         }
 726     }
 727     SvREFCNT_dec(PL_strtab);
 728
 729 #ifdef USE_ITHREADS
 730     /* free the pointer table used for cloning */
 731     ptr_table_free(PL_ptr_table);
 732 #endif
 733
 734     /* free special SVs */
 735
 736     SvREFCNT(&PL_sv_yes) = 0;
 737     sv_clear(&PL_sv_yes);
 738     SvANY(&PL_sv_yes) = NULL;
 739     SvFLAGS(&PL_sv_yes) = 0;
 740
 741     SvREFCNT(&PL_sv_no) = 0;
 742     sv_clear(&PL_sv_no);
 743     SvANY(&PL_sv_no) = NULL;
 744     SvFLAGS(&PL_sv_no) = 0;
 745
 746     {
 747         int i;
 748         for (i=0; i<=2; i++) {
 749             SvREFCNT(PERL_DEBUG_PAD(i)) = 0;
 750             sv_clear(PERL_DEBUG_PAD(i));
 751             SvANY(PERL_DEBUG_PAD(i)) = NULL;
 752             SvFLAGS(PERL_DEBUG_PAD(i)) = 0;
 753         }
 754     }
 755
 756     if (PL_sv_count != 0 && ckWARN_d(WARN_INTERNAL))
 757         Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Scalars leaked: %ld\n", (long)PL_sv_count);
 758
 759 #ifdef DEBUG_LEAKING_SCALARS
 760     if (PL_sv_count != 0) {
 761         SV* sva;
 762         SV* sv;
 763         register SV* svend;
 764
 765         for (sva = PL_sv_arenaroot; sva; sva = (SV*)SvANY(sva)) {
 766             svend = &sva[SvREFCNT(sva)];
 767             for (sv = sva + 1; sv < svend; ++sv) {
 768                 if (SvTYPE(sv) != SVTYPEMASK) {
 769                     PerlIO_printf(Perl_debug_log, "leaked: 0x%p\n", sv);
 770                 }
 771             }
 772         }
 773     }
 774 #endif
 775
 776
 777 #if defined(PERLIO_LAYERS)
 778     /* No more IO - including error messages ! */
 779     PerlIO_cleanup(aTHX);
 780 #endif
 781
 782     /* sv_undef needs to stay immortal until after PerlIO_cleanup
 783        as currently layers use it rather than Nullsv as a marker
 784        for no arg - and will try and SvREFCNT_dec it.
 785      */
 786     SvREFCNT(&PL_sv_undef) = 0;
 787     SvREADONLY_off(&PL_sv_undef);
 788
 789     SvREFCNT(&PL_sv_placeholder) = 0;
 790     SvREADONLY_off(&PL_sv_placeholder);
 791
 792     Safefree(PL_origfilename);
 793     Safefree(PL_reg_start_tmp);
 794     if (PL_reg_curpm)
 795         Safefree(PL_reg_curpm);
 796     Safefree(PL_reg_poscache);
 797     free_tied_hv_pool();
 798     Safefree(PL_op_mask);
 799     Safefree(PL_psig_ptr);
 800     Safefree(PL_psig_name);
 801     Safefree(PL_bitcount);
 802     Safefree(PL_psig_pend);
 803     nuke_stacks();
 804     PL_hints = 0;               /* Reset hints. Should hints be per-interpreter ? */
 805
 806     DEBUG_P(debprofdump());
 807
 808 #ifdef USE_REENTRANT_API
 809     Perl_reentrant_free(aTHX);
 810 #endif
 811
 812     sv_free_arenas();
 813
 814     /* As the absolutely last thing, free the non-arena SV for mess() */
 815
 816     if (PL_mess_sv) {
 817         /* it could have accumulated taint magic */
 818         if (SvTYPE(PL_mess_sv) >= SVt_PVMG) {
 819             MAGIC* mg;
 820             MAGIC* moremagic;
 821             for (mg = SvMAGIC(PL_mess_sv); mg; mg = moremagic) {
 822                 moremagic = mg->mg_moremagic;
 823                 if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global
 824                                                 && mg->mg_len >= 0)
 825                     Safefree(mg->mg_ptr);
 826                 Safefree(mg);
 827             }
 828         }
 829         /* we know that type >= SVt_PV */
 830         (void)SvOOK_off(PL_mess_sv);
 831         Safefree(SvPVX(PL_mess_sv));
 832         Safefree(SvANY(PL_mess_sv));
 833         Safefree(PL_mess_sv);
 834         PL_mess_sv = Nullsv;
 835     }
 836     return STATUS_NATIVE_EXPORT;
 837 }
 838
 839 /*
 840 =for apidoc perl_free
 841
 842 Releases a Perl interpreter.  See L<perlembed>.
 843
 844 =cut
 845 */
 846
 847 void
 848 perl_free(pTHXx)
 849 {
 850 #if defined(WIN32) || defined(NETWARE)
 851 #  if defined(PERL_IMPLICIT_SYS)
 852 #    ifdef NETWARE
 853     void *host = nw_internal_host;
 854 #    else
 855     void *host = w32_internal_host;
 856 #    endif
 857     PerlMem_free(aTHXx);
 858 #    ifdef NETWARE
 859     nw_delete_internal_host(host);
 860 #    else
 861     win32_delete_internal_host(host);
 862 #    endif
 863 #  else
 864     PerlMem_free(aTHXx);
 865 #  endif
 866 #else
 867     PerlMem_free(aTHXx);
 868 #endif
 869 }
 870
 871 void
 872 Perl_call_atexit(pTHX_ ATEXIT_t fn, void *ptr)
 873 {
 874     Renew(PL_exitlist, PL_exitlistlen+1, PerlExitListEntry);
 875     PL_exitlist[PL_exitlistlen].fn = fn;
 876     PL_exitlist[PL_exitlistlen].ptr = ptr;
 877     ++PL_exitlistlen;
 878 }
 879
 880 /*
 881 =for apidoc perl_parse
 882
 883 Tells a Perl interpreter to parse a Perl script.  See L<perlembed>.
 884
 885 =cut
 886 */
 887
 888 int
 889 perl_parse(pTHXx_ XSINIT_t xsinit, int argc, char **argv, char **env)
 890 {
 891     I32 oldscope;
 892     int ret;
 893     dJMPENV;
 894 #ifdef USE_5005THREADS
 895     dTHX;
 896 #endif
 897
 898 #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
 899 #ifdef IAMSUID
 900 #undef IAMSUID
 901     Perl_croak(aTHX_ "suidperl is no longer needed since the kernel can now execute\n\
 902 setuid perl scripts securely.\n");
 903 #endif
 904 #endif
 905
 906 #if defined(USE_HASH_SEED) || defined(USE_HASH_SEED_EXPLICIT)
 907     /* [perl #22371] Algorimic Complexity Attack on Perl 5.6.1, 5.8.0
 908      * This MUST be done before any hash stores or fetches take place.
 909      * If you set PL_hash_seed (and assumedly also PL_hash_seed_set) yourself,
 910      * it is your responsibility to provide a good random seed!
 911      * You can also define PERL_HASH_SEED in compile time, see hv.h. */
 912     if (!PL_hash_seed_set)
 913          PL_hash_seed = get_hash_seed();
 914     {
 915          char *s = PerlEnv_getenv("PERL_HASH_SEED_DEBUG");
 916
 917          if (s) {
 918               int i = atoi(s);
 919
 920               if (i == 1)
 921                    PerlIO_printf(Perl_debug_log, "HASH_SEED = %"UVuf"\n",
 922                                  PL_hash_seed);
 923          }
 924     }
 925 #endif /* #if defined(USE_HASH_SEED) || defined(USE_HASH_SEED_EXPLICIT) */
 926
 927     PL_origargc = argc;
 928     PL_origargv = argv;
 929
 930     {
 931         /* Set PL_origalen be the sum of the contiguous argv[]
 932          * elements plus the size of the env in case that it is
 933          * contiguous with the argv[].  This is used in mg.c:mg_set()
 934          * as the maximum modifiable length of $0.  In the worst case
 935          * the area we are able to modify is limited to the size of
 936          * the original argv[0].  (See below for 'contiguous', though.)
 937          * --jhi */
 938          char *s = NULL;
 939          int i;
 940          UV mask =
 941            ~(UV)(PTRSIZE == 4 ? 3 : PTRSIZE == 8 ? 7 : PTRSIZE == 16 ? 15 : 0);
 942          /* Do the mask check only if the args seem like aligned. */
 943          UV aligned =
 944            (mask < ~(UV)0) && ((PTR2UV(argv[0]) & mask) == PTR2UV(argv[0]));
 945
 946          /* See if all the arguments are contiguous in memory.  Note
 947           * that 'contiguous' is a loose term because some platforms
 948           * align the argv[] and the envp[].  If the arguments look
 949           * like non-aligned, assume that they are 'strictly' or
 950           * 'traditionally' contiguous.  If the arguments look like
 951           * aligned, we just check that they are within aligned
 952           * PTRSIZE bytes.  As long as no system has something bizarre
 953           * like the argv[] interleaved with some other data, we are
 954           * fine.  (Did I just evoke Murphy's Law?)  --jhi */
 955          if (PL_origargv && PL_origargc >= 1 && (s = PL_origargv[0])) {
 956               while (*s) s++;
 957               for (i = 1; i < PL_origargc; i++) {
 958                    if ((PL_origargv[i] == s + 1
 959 #ifdef OS2
 960                         || PL_origargv[i] == s + 2
 961 #endif
 962                             )
 963                        ||
 964                        (aligned &&
 965                         (PL_origargv[i] >  s &&
 966                          PL_origargv[i] <=
 967                          INT2PTR(char *, PTR2UV(s + PTRSIZE) & mask)))
 968                         )
 969                    {
 970                         s = PL_origargv[i];
 971                         while (*s) s++;
 972                    }
 973                    else
 974                         break;
 975               }
 976          }
 977          /* Can we grab env area too to be used as the area for $0? */
 978          if (PL_origenviron) {
 979               if ((PL_origenviron[0] == s + 1
 980 #ifdef OS2
 981                    || (PL_origenviron[0] == s + 9 && (s += 8))
 982 #endif
 983                   )
 984                   ||
 985                   (aligned &&
 986                    (PL_origenviron[0] >  s &&
 987                     PL_origenviron[0] <=
 988                     INT2PTR(char *, PTR2UV(s + PTRSIZE) & mask)))
 989                  )
 990               {
 991 #ifndef OS2
 992                    s = PL_origenviron[0];
 993                    while (*s) s++;
 994 #endif
 995                    my_setenv("NoNe  SuCh", Nullch);
 996                    /* Force copy of environment. */
 997                    for (i = 1; PL_origenviron[i]; i++) {
 998                         if (PL_origenviron[i] == s + 1
 999                             ||
1000                             (aligned &&
1001                              (PL_origenviron[i] >  s &&
1002                               PL_origenviron[i] <=
1003                               INT2PTR(char *, PTR2UV(s + PTRSIZE) & mask)))
1004                            )
1005                         {
1006                              s = PL_origenviron[i];
1007                              while (*s) s++;
1008                         }
1009                         else
1010                              break;
1011                    }
1012               }
1013          }
1014          PL_origalen = s - PL_origargv[0];
1015     }
1016
1017     if (PL_do_undump) {
1018
1019         /* Come here if running an undumped a.out. */
1020
1021         PL_origfilename = savepv(argv[0]);
1022         PL_do_undump = FALSE;
1023         cxstack_ix = -1;                /* start label stack again */
1024         init_ids();
1025         init_postdump_symbols(argc,argv,env);
1026         return 0;
1027     }
1028
1029     if (PL_main_root) {
1030         op_free(PL_main_root);
1031         PL_main_root = Nullop;
1032     }
1033     PL_main_start = Nullop;
1034     SvREFCNT_dec(PL_main_cv);
1035     PL_main_cv = Nullcv;
1036
1037     time(&PL_basetime);
1038     oldscope = PL_scopestack_ix;
1039     PL_dowarn = G_WARN_OFF;
1040
1041 #ifdef PERL_FLEXIBLE_EXCEPTIONS
1042     CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_vparse_body), env, xsinit);
1043 #else
1044     JMPENV_PUSH(ret);
1045 #endif
1046     switch (ret) {
1047     case 0:
1048 #ifndef PERL_FLEXIBLE_EXCEPTIONS
1049         parse_body(env,xsinit);
1050 #endif
1051         if (PL_checkav)
1052             call_list(oldscope, PL_checkav);
1053         ret = 0;
1054         break;
1055     case 1:
1056         STATUS_ALL_FAILURE;
1057         /* FALL THROUGH */
1058     case 2:
1059         /* my_exit() was called */
1060         while (PL_scopestack_ix > oldscope)
1061             LEAVE;
1062         FREETMPS;
1063         PL_curstash = PL_defstash;
1064         if (PL_checkav)
1065             call_list(oldscope, PL_checkav);
1066         ret = STATUS_NATIVE_EXPORT;
1067         break;
1068     case 3:
1069         PerlIO_printf(Perl_error_log, "panic: top_env\n");
1070         ret = 1;
1071         break;
1072     }
1073     JMPENV_POP;
1074     return ret;
1075 }
1076
1077 #ifdef PERL_FLEXIBLE_EXCEPTIONS
1078 STATIC void *
1079 S_vparse_body(pTHX_ va_list args)
1080 {
1081     char **env = va_arg(args, char**);
1082     XSINIT_t xsinit = va_arg(args, XSINIT_t);
1083
1084     return parse_body(env, xsinit);
1085 }
1086 #endif
1087
1088 STATIC void *
1089 S_parse_body(pTHX_ char **env, XSINIT_t xsinit)
1090 {
1091     int argc = PL_origargc;
1092     char **argv = PL_origargv;
1093     char *scriptname = NULL;
1094     int fdscript = -1;
1095     VOL bool dosearch = FALSE;
1096     char *validarg = "";
1097     register SV *sv;
1098     register char *s;
1099     char *cddir = Nullch;
1100
1101     sv_setpvn(PL_linestr,"",0);
1102     sv = newSVpvn("",0);                /* first used for -I flags */
1103     SAVEFREESV(sv);
1104     init_main_stash();
1105
1106     for (argc--,argv++; argc > 0; argc--,argv++) {
1107         if (argv[0][0] != '-' || !argv[0][1])
1108             break;
1109 #ifdef DOSUID
1110     if (*validarg)
1111         validarg = " PHOOEY ";
1112     else
1113         validarg = argv[0];
1114 #endif
1115         s = argv[0]+1;
1116       reswitch:
1117         switch (*s) {
1118         case 'C':
1119 #ifndef PERL_STRICT_CR
1120         case '\r':
1121 #endif
1122         case ' ':
1123         case '0':
1124         case 'F':
1125         case 'a':
1126         case 'c':
1127         case 'd':
1128         case 'D':
1129         case 'h':
1130         case 'i':
1131         case 'l':
1132         case 'M':
1133         case 'm':
1134         case 'n':
1135         case 'p':
1136         case 's':
1137         case 'u':
1138         case 'U':
1139         case 'v':
1140         case 'W':
1141         case 'X':
1142         case 'w':
1143         case 'A':
1144             if ((s = moreswitches(s)))
1145                 goto reswitch;
1146             break;
1147
1148         case 't':
1149             CHECK_MALLOC_TOO_LATE_FOR('t');
1150             if( !PL_tainting ) {
1151                  PL_taint_warn = TRUE;
1152                  PL_tainting = TRUE;
1153             }
1154             s++;
1155             goto reswitch;
1156         case 'T':
1157             CHECK_MALLOC_TOO_LATE_FOR('T');
1158             PL_tainting = TRUE;
1159             PL_taint_warn = FALSE;
1160             s++;
1161             goto reswitch;
1162
1163         case 'e':
1164 #ifdef MACOS_TRADITIONAL
1165             /* ignore -e for Dev:Pseudo argument */
1166             if (argv[1] && !strcmp(argv[1], "Dev:Pseudo"))
1167                 break;
1168 #endif
1169             if (PL_euid != PL_uid || PL_egid != PL_gid)
1170                 Perl_croak(aTHX_ "No -e allowed in setuid scripts");
1171             if (!PL_e_script) {
1172                 PL_e_script = newSVpvn("",0);
1173                 filter_add(read_e_script, NULL);
1174             }
1175             if (*++s)
1176                 sv_catpv(PL_e_script, s);
1177             else if (argv[1]) {
1178                 sv_catpv(PL_e_script, argv[1]);
1179                 argc--,argv++;
1180             }
1181             else
1182                 Perl_croak(aTHX_ "No code specified for -e");
1183             sv_catpv(PL_e_script, "\n");
1184             break;
1185
1186         case 'I':       /* -I handled both here and in moreswitches() */
1187             forbid_setid("-I");
1188             if (!*++s && (s=argv[1]) != Nullch) {
1189                 argc--,argv++;
1190             }
1191             if (s && *s) {
1192                 char *p;
1193                 STRLEN len = strlen(s);
1194                 p = savepvn(s, len);
1195                 incpush(p, TRUE, TRUE, FALSE);
1196                 sv_catpvn(sv, "-I", 2);
1197                 sv_catpvn(sv, p, len);
1198                 sv_catpvn(sv, " ", 1);
1199                 Safefree(p);
1200             }
1201             else
1202                 Perl_croak(aTHX_ "No directory specified for -I");
1203             break;
1204         case 'P':
1205             forbid_setid("-P");
1206             PL_preprocess = TRUE;
1207             s++;
1208             goto reswitch;
1209         case 'S':
1210             forbid_setid("-S");
1211             dosearch = TRUE;
1212             s++;
1213             goto reswitch;
1214         case 'V':
1215             if (!PL_preambleav)
1216                 PL_preambleav = newAV();
1217             av_push(PL_preambleav, newSVpv("use Config qw(myconfig config_vars)",0));
1218             if (*++s != ':')  {
1219                 PL_Sv = newSVpv("print myconfig();",0);
1220 #ifdef VMS
1221                 sv_catpv(PL_Sv,"print \"\\nCharacteristics of this PERLSHR image: \\n\",");
1222 #else
1223                 sv_catpv(PL_Sv,"print \"\\nCharacteristics of this binary (from libperl): \\n\",");
1224 #endif
1225                 sv_catpv(PL_Sv,"\"  Compile-time options:");
1226 #  ifdef DEBUGGING
1227                 sv_catpv(PL_Sv," DEBUGGING");
1228 #  endif
1229 #  ifdef MULTIPLICITY
1230                 sv_catpv(PL_Sv," MULTIPLICITY");
1231 #  endif
1232 #  ifdef USE_5005THREADS
1233                 sv_catpv(PL_Sv," USE_5005THREADS");
1234 #  endif
1235 #  ifdef USE_ITHREADS
1236                 sv_catpv(PL_Sv," USE_ITHREADS");
1237 #  endif
1238 #  ifdef USE_64_BIT_INT
1239                 sv_catpv(PL_Sv," USE_64_BIT_INT");
1240 #  endif
1241 #  ifdef USE_64_BIT_ALL
1242                 sv_catpv(PL_Sv," USE_64_BIT_ALL");
1243 #  endif
1244 #  ifdef USE_LONG_DOUBLE
1245                 sv_catpv(PL_Sv," USE_LONG_DOUBLE");
1246 #  endif
1247 #  ifdef USE_LARGE_FILES
1248                 sv_catpv(PL_Sv," USE_LARGE_FILES");
1249 #  endif
1250 #  ifdef USE_SOCKS
1251                 sv_catpv(PL_Sv," USE_SOCKS");
1252 #  endif
1253 #  ifdef PERL_IMPLICIT_CONTEXT
1254                 sv_catpv(PL_Sv," PERL_IMPLICIT_CONTEXT");
1255 #  endif
1256 #  ifdef PERL_IMPLICIT_SYS
1257                 sv_catpv(PL_Sv," PERL_IMPLICIT_SYS");
1258 #  endif
1259                 sv_catpv(PL_Sv,"\\n\",");
1260
1261 #if defined(LOCAL_PATCH_COUNT)
1262                 if (LOCAL_PATCH_COUNT > 0) {
1263                     int i;
1264                     sv_catpv(PL_Sv,"\"  Locally applied patches:\\n\",");
1265                     for (i = 1; i <= LOCAL_PATCH_COUNT; i++) {
1266                         if (PL_localpatches[i])
1267                             Perl_sv_catpvf(aTHX_ PL_Sv,"q\"  \t%s\n\",",PL_localpatches[i]);
1268                     }
1269                 }
1270 #endif
1271                 Perl_sv_catpvf(aTHX_ PL_Sv,"\"  Built under %s\\n\"",OSNAME);
1272 #ifdef __DATE__
1273 #  ifdef __TIME__
1274                 Perl_sv_catpvf(aTHX_ PL_Sv,",\"  Compiled at %s %s\\n\"",__DATE__,__TIME__);
1275 #  else
1276                 Perl_sv_catpvf(aTHX_ PL_Sv,",\"  Compiled on %s\\n\"",__DATE__);
1277 #  endif
1278 #endif
1279                 sv_catpv(PL_Sv, "; \
1280 $\"=\"\\n    \"; \
1281 @env = map { \"$_=\\\"$ENV{$_}\\\"\" } sort grep {/^PERL/} keys %ENV; ");
1282 #ifdef __CYGWIN__
1283                 sv_catpv(PL_Sv,"\
1284 push @env, \"CYGWIN=\\\"$ENV{CYGWIN}\\\"\";");
1285 #endif
1286                 sv_catpv(PL_Sv, "\
1287 print \"  \\%ENV:\\n    @env\\n\" if @env; \
1288 print \"  \\@INC:\\n    @INC\\n\";");
1289             }
1290             else {
1291                 PL_Sv = newSVpv("config_vars(qw(",0);
1292                 sv_catpv(PL_Sv, ++s);
1293                 sv_catpv(PL_Sv, "))");
1294                 s += strlen(s);
1295             }
1296             av_push(PL_preambleav, PL_Sv);
1297             scriptname = BIT_BUCKET;    /* don't look for script or read stdin */
1298             goto reswitch;
1299         case 'x':
1300             PL_doextract = TRUE;
1301             s++;
1302             if (*s)
1303                 cddir = s;
1304             break;
1305         case 0:
1306             break;
1307         case '-':
1308             if (!*++s || isSPACE(*s)) {
1309                 argc--,argv++;
1310                 goto switch_end;
1311             }
1312             /* catch use of gnu style long options */
1313             if (strEQ(s, "version")) {
1314                 s = "v";
1315                 goto reswitch;
1316             }
1317             if (strEQ(s, "help")) {
1318                 s = "h";
1319                 goto reswitch;
1320             }
1321             s--;
1322             /* FALL THROUGH */
1323         default:
1324             Perl_croak(aTHX_ "Unrecognized switch: -%s  (-h will show valid options)",s);
1325         }
1326     }
1327   switch_end:
1328     sv_setsv(get_sv("/", TRUE), PL_rs);
1329
1330     if (
1331 #ifndef SECURE_INTERNAL_GETENV
1332         !PL_tainting &&
1333 #endif
1334         (s = PerlEnv_getenv("PERL5OPT")))
1335     {
1336         char *popt = s;
1337         while (isSPACE(*s))
1338             s++;
1339         if (*s == '-' && *(s+1) == 'T') {
1340             CHECK_MALLOC_TOO_LATE_FOR('T');
1341             PL_tainting = TRUE;
1342             PL_taint_warn = FALSE;
1343         }
1344         else {
1345             char *popt_copy = Nullch;
1346             while (s && *s) {
1347                 char *d;
1348                 while (isSPACE(*s))
1349                     s++;
1350                 if (*s == '-') {
1351                     s++;
1352                     if (isSPACE(*s))
1353                         continue;
1354                 }
1355                 d = s;
1356                 if (!*s)
1357                     break;
1358                 if (!strchr("DIMUdmtwA", *s))
1359                     Perl_croak(aTHX_ "Illegal switch in PERL5OPT: -%c", *s);
1360                 while (++s && *s) {
1361                     if (isSPACE(*s)) {
1362                         if (!popt_copy) {
1363                             popt_copy = SvPVX(sv_2mortal(newSVpv(popt,0)));
1364                             s = popt_copy + (s - popt);
1365                             d = popt_copy + (d - popt);
1366                         }
1367                         *s++ = '\0';
1368                         break;
1369                     }
1370                 }
1371                 if (*d == 't') {
1372                     if( !PL_tainting ) {
1373                         PL_taint_warn = TRUE;
1374                         PL_tainting = TRUE;
1375                     }
1376                 } else {
1377                     moreswitches(d);
1378                 }
1379             }
1380         }
1381     }
1382
1383     if (PL_taint_warn && PL_dowarn != G_WARN_ALL_OFF) {
1384        PL_compiling.cop_warnings = newSVpvn(WARN_TAINTstring, WARNsize);
1385     }
1386
1387     if (!scriptname)
1388         scriptname = argv[0];
1389     if (PL_e_script) {
1390         argc++,argv--;
1391         scriptname = BIT_BUCKET;        /* don't look for script or read stdin */
1392     }
1393     else if (scriptname == Nullch) {
1394 #ifdef MSDOS
1395         if ( PerlLIO_isatty(PerlIO_fileno(PerlIO_stdin())) )
1396             moreswitches("h");
1397 #endif
1398         scriptname = "-";
1399     }
1400
1401     init_perllib();
1402
1403     open_script(scriptname,dosearch,sv,&fdscript);
1404
1405     validate_suid(validarg, scriptname,fdscript);
1406
1407 #ifndef PERL_MICRO
1408 #if defined(SIGCHLD) || defined(SIGCLD)
1409     {
1410 #ifndef SIGCHLD
1411 #  define SIGCHLD SIGCLD
1412 #endif
1413         Sighandler_t sigstate = rsignal_state(SIGCHLD);
1414         if (sigstate == SIG_IGN) {
1415             if (ckWARN(WARN_SIGNAL))
1416                 Perl_warner(aTHX_ packWARN(WARN_SIGNAL),
1417                             "Can't ignore signal CHLD, forcing to default");
1418             (void)rsignal(SIGCHLD, (Sighandler_t)SIG_DFL);
1419         }
1420     }
1421 #endif
1422 #endif
1423
1424 #ifdef MACOS_TRADITIONAL
1425     if (PL_doextract || gMacPerl_AlwaysExtract) {
1426 #else
1427     if (PL_doextract) {
1428 #endif
1429         find_beginning();
1430         if (cddir && PerlDir_chdir(cddir) < 0)
1431             Perl_croak(aTHX_ "Can't chdir to %s",cddir);
1432
1433     }
1434
1435     PL_main_cv = PL_compcv = (CV*)NEWSV(1104,0);
1436     sv_upgrade((SV *)PL_compcv, SVt_PVCV);
1437     CvUNIQUE_on(PL_compcv);
1438
1439     CvPADLIST(PL_compcv) = pad_new(0);
1440 #ifdef USE_5005THREADS
1441     CvOWNER(PL_compcv) = 0;
1442     New(666, CvMUTEXP(PL_compcv), 1, perl_mutex);
1443     MUTEX_INIT(CvMUTEXP(PL_compcv));
1444 #endif /* USE_5005THREADS */
1445
1446     boot_core_PerlIO();
1447     boot_core_UNIVERSAL();
1448 #ifndef PERL_MICRO
1449     boot_core_xsutils();
1450 #endif
1451
1452     if (xsinit)
1453         (*xsinit)(aTHX);        /* in case linked C routines want magical variables */
1454 #ifndef PERL_MICRO
1455 #if defined(VMS) || defined(WIN32) || defined(DJGPP) || defined(__CYGWIN__) || defined(EPOC)
1456     init_os_extras();
1457 #endif
1458 #endif
1459
1460 #ifdef USE_SOCKS
1461 #   ifdef HAS_SOCKS5_INIT
1462     socks5_init(argv[0]);
1463 #   else
1464     SOCKSinit(argv[0]);
1465 #   endif
1466 #endif
1467
1468     init_predump_symbols();
1469     /* init_postdump_symbols not currently designed to be called */
1470     /* more than once (ENV isn't cleared first, for example)     */
1471     /* But running with -u leaves %ENV & @ARGV undefined!    XXX */
1472     if (!PL_do_undump)
1473         init_postdump_symbols(argc,argv,env);
1474
1475     /* PL_unicode is turned on by -C or by $ENV{PERL_UNICODE}.
1476      * PL_utf8locale is conditionally turned on by
1477      * locale.c:Perl_init_i18nl10n() if the environment
1478      * look like the user wants to use UTF-8. */
1479     if (PL_unicode) {
1480          /* Requires init_predump_symbols(). */
1481          if (!(PL_unicode & PERL_UNICODE_LOCALE_FLAG) || PL_utf8locale) {
1482               IO* io;
1483               PerlIO* fp;
1484               SV* sv;
1485
1486               /* Turn on UTF-8-ness on STDIN, STDOUT, STDERR
1487                * and the default open disciplines. */
1488               if ((PL_unicode & PERL_UNICODE_STDIN_FLAG) &&
1489                   PL_stdingv  && (io = GvIO(PL_stdingv)) &&
1490                   (fp = IoIFP(io)))
1491                    PerlIO_binmode(aTHX_ fp, IoTYPE(io), 0, ":utf8");
1492               if ((PL_unicode & PERL_UNICODE_STDOUT_FLAG) &&
1493                   PL_defoutgv && (io = GvIO(PL_defoutgv)) &&
1494                   (fp = IoOFP(io)))
1495                    PerlIO_binmode(aTHX_ fp, IoTYPE(io), 0, ":utf8");
1496               if ((PL_unicode & PERL_UNICODE_STDERR_FLAG) &&
1497                   PL_stderrgv && (io = GvIO(PL_stderrgv)) &&
1498                   (fp = IoOFP(io)))
1499                    PerlIO_binmode(aTHX_ fp, IoTYPE(io), 0, ":utf8");
1500               if ((PL_unicode & PERL_UNICODE_INOUT_FLAG) &&
1501                   (sv = GvSV(gv_fetchpv("\017PEN", TRUE, SVt_PV)))) {
1502                    U32 in  = PL_unicode & PERL_UNICODE_IN_FLAG;
1503                    U32 out = PL_unicode & PERL_UNICODE_OUT_FLAG;
1504                    if (in) {
1505                         if (out)
1506                              sv_setpvn(sv, ":utf8\0:utf8", 11);
1507                         else
1508                              sv_setpvn(sv, ":utf8\0", 6);
1509                    }
1510                    else if (out)
1511                         sv_setpvn(sv, "\0:utf8", 6);
1512                    SvSETMAGIC(sv);
1513               }
1514          }
1515     }
1516
1517     if ((s = PerlEnv_getenv("PERL_SIGNALS"))) {
1518          if (strEQ(s, "unsafe"))
1519               PL_signals |=  PERL_SIGNALS_UNSAFE_FLAG;
1520          else if (strEQ(s, "safe"))
1521               PL_signals &= ~PERL_SIGNALS_UNSAFE_FLAG;
1522          else
1523               Perl_croak(aTHX_ "PERL_SIGNALS illegal: \"%s\"", s);
1524     }
1525
1526     init_lexer();
1527
1528     /* now parse the script */
1529
1530     SETERRNO(0,SS_NORMAL);
1531     PL_error_count = 0;
1532 #ifdef MACOS_TRADITIONAL
1533     if (gMacPerl_SyntaxError = (yyparse() || PL_error_count)) {
1534         if (PL_minus_c)
1535             Perl_croak(aTHX_ "%s had compilation errors.\n", MacPerl_MPWFileName(PL_origfilename));
1536         else {
1537             Perl_croak(aTHX_ "Execution of %s aborted due to compilation errors.\n",
1538                        MacPerl_MPWFileName(PL_origfilename));
1539         }
1540     }
1541 #else
1542     if (yyparse() || PL_error_count) {
1543         if (PL_minus_c)
1544             Perl_croak(aTHX_ "%s had compilation errors.\n", PL_origfilename);
1545         else {
1546             Perl_croak(aTHX_ "Execution of %s aborted due to compilation errors.\n",
1547                        PL_origfilename);
1548         }
1549     }
1550 #endif
1551     CopLINE_set(PL_curcop, 0);
1552     PL_curstash = PL_defstash;
1553     PL_preprocess = FALSE;
1554     if (PL_e_script) {
1555         SvREFCNT_dec(PL_e_script);
1556         PL_e_script = Nullsv;
1557     }
1558
1559     if (PL_do_undump)
1560         my_unexec();
1561
1562     if (isWARN_ONCE) {
1563         SAVECOPFILE(PL_curcop);
1564         SAVECOPLINE(PL_curcop);
1565         gv_check(PL_defstash);
1566     }
1567
1568     LEAVE;
1569     FREETMPS;
1570
1571 #ifdef MYMALLOC
1572     if ((s=PerlEnv_getenv("PERL_DEBUG_MSTATS")) && atoi(s) >= 2)
1573         dump_mstats("after compilation:");
1574 #endif
1575
1576     ENTER;
1577     PL_restartop = 0;
1578     return NULL;
1579 }
1580
1581 /*
1582 =for apidoc perl_run
1583
1584 Tells a Perl interpreter to run.  See L<perlembed>.
1585
1586 =cut
1587 */
1588
1589 int
1590 perl_run(pTHXx)
1591 {
1592     I32 oldscope;
1593     int ret = 0;
1594     dJMPENV;
1595 #ifdef USE_5005THREADS
1596     dTHX;
1597 #endif
1598
1599     oldscope = PL_scopestack_ix;
1600 #ifdef VMS
1601     VMSISH_HUSHED = 0;
1602 #endif
1603
1604 #ifdef PERL_FLEXIBLE_EXCEPTIONS
1605  redo_body:
1606     CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_vrun_body), oldscope);
1607 #else
1608     JMPENV_PUSH(ret);
1609 #endif
1610     switch (ret) {
1611     case 1:
1612         cxstack_ix = -1;                /* start context stack again */
1613         goto redo_body;
1614     case 0:                             /* normal completion */
1615 #ifndef PERL_FLEXIBLE_EXCEPTIONS
1616  redo_body:
1617         run_body(oldscope);
1618 #endif
1619         /* FALL THROUGH */
1620     case 2:                             /* my_exit() */
1621         while (PL_scopestack_ix > oldscope)
1622             LEAVE;
1623         FREETMPS;
1624         PL_curstash = PL_defstash;
1625         if (!(PL_exit_flags & PERL_EXIT_DESTRUCT_END) &&
1626             PL_endav && !PL_minus_c)
1627             call_list(oldscope, PL_endav);
1628 #ifdef MYMALLOC
1629         if (PerlEnv_getenv("PERL_DEBUG_MSTATS"))
1630             dump_mstats("after execution:  ");
1631 #endif
1632         ret = STATUS_NATIVE_EXPORT;
1633         break;
1634     case 3:
1635         if (PL_restartop) {
1636             POPSTACK_TO(PL_mainstack);
1637             goto redo_body;
1638         }
1639         PerlIO_printf(Perl_error_log, "panic: restartop\n");
1640         FREETMPS;
1641         ret = 1;
1642         break;
1643     }
1644
1645     JMPENV_POP;
1646     return ret;
1647 }
1648
1649 #ifdef PERL_FLEXIBLE_EXCEPTIONS
1650 STATIC void *
1651 S_vrun_body(pTHX_ va_list args)
1652 {
1653     I32 oldscope = va_arg(args, I32);
1654
1655     return run_body(oldscope);
1656 }
1657 #endif
1658
1659
1660 STATIC void *
1661 S_run_body(pTHX_ I32 oldscope)
1662 {
1663     DEBUG_r(PerlIO_printf(Perl_debug_log, "%s $` $& $' support.\n",
1664                     PL_sawampersand ? "Enabling" : "Omitting"));
1665
1666     if (!PL_restartop) {
1667         DEBUG_x(dump_all());
1668         PERL_DEBUG(PerlIO_printf(Perl_debug_log, "\nEXECUTING...\n\n"));
1669         DEBUG_S(PerlIO_printf(Perl_debug_log, "main thread is 0x%"UVxf"\n",
1670                               PTR2UV(thr)));
1671
1672         if (PL_minus_c) {
1673 #ifdef MACOS_TRADITIONAL
1674             PerlIO_printf(Perl_error_log, "%s%s syntax OK\n",
1675                 (gMacPerl_ErrorFormat ? "# " : ""),
1676                 MacPerl_MPWFileName(PL_origfilename));
1677 #else
1678             PerlIO_printf(Perl_error_log, "%s syntax OK\n", PL_origfilename);
1679 #endif
1680             my_exit(0);
1681         }
1682         if (PERLDB_SINGLE && PL_DBsingle)
1683             sv_setiv(PL_DBsingle, 1);
1684         if (PL_initav)
1685             call_list(oldscope, PL_initav);
1686     }
1687
1688     /* do it */
1689
1690     if (PL_restartop) {
1691         PL_op = PL_restartop;
1692         PL_restartop = 0;
1693         CALLRUNOPS(aTHX);
1694     }
1695     else if (PL_main_start) {
1696         CvDEPTH(PL_main_cv) = 1;
1697         PL_op = PL_main_start;
1698         CALLRUNOPS(aTHX);
1699     }
1700
1701     my_exit(0);
1702     /* NOTREACHED */
1703     return NULL;
1704 }
1705
1706 /*
1707 =head1 SV Manipulation Functions
1708
1709 =for apidoc p||get_sv
1710
1711 Returns the SV of the specified Perl scalar.  If C<create> is set and the
1712 Perl variable does not exist then it will be created.  If C<create> is not
1713 set and the variable does not exist then NULL is returned.
1714
1715 =cut
1716 */
1717
1718 SV*
1719 Perl_get_sv(pTHX_ const char *name, I32 create)
1720 {
1721     GV *gv;
1722 #ifdef USE_5005THREADS
1723     if (name[1] == '\0' && !isALPHA(name[0])) {
1724         PADOFFSET tmp = find_threadsv(name);
1725         if (tmp != NOT_IN_PAD)
1726             return THREADSV(tmp);
1727     }
1728 #endif /* USE_5005THREADS */
1729     gv = gv_fetchpv(name, create, SVt_PV);
1730     if (gv)
1731         return GvSV(gv);
1732     return Nullsv;
1733 }
1734
1735 /*
1736 =head1 Array Manipulation Functions
1737
1738 =for apidoc p||get_av
1739
1740 Returns the AV of the specified Perl array.  If C<create> is set and the
1741 Perl variable does not exist then it will be created.  If C<create> is not
1742 set and the variable does not exist then NULL is returned.
1743
1744 =cut
1745 */
1746
1747 AV*
1748 Perl_get_av(pTHX_ const char *name, I32 create)
1749 {
1750     GV* gv = gv_fetchpv(name, create, SVt_PVAV);
1751     if (create)
1752         return GvAVn(gv);
1753     if (gv)
1754         return GvAV(gv);
1755     return Nullav;
1756 }
1757
1758 /*
1759 =head1 Hash Manipulation Functions
1760
1761 =for apidoc p||get_hv
1762
1763 Returns the HV of the specified Perl hash.  If C<create> is set and the
1764 Perl variable does not exist then it will be created.  If C<create> is not
1765 set and the variable does not exist then NULL is returned.
1766
1767 =cut
1768 */
1769
1770 HV*
1771 Perl_get_hv(pTHX_ const char *name, I32 create)
1772 {
1773     GV* gv = gv_fetchpv(name, create, SVt_PVHV);
1774     if (create)
1775         return GvHVn(gv);
1776     if (gv)
1777         return GvHV(gv);
1778     return Nullhv;
1779 }
1780
1781 /*
1782 =head1 CV Manipulation Functions
1783
1784 =for apidoc p||get_cv
1785
1786 Returns the CV of the specified Perl subroutine.  If C<create> is set and
1787 the Perl subroutine does not exist then it will be declared (which has the
1788 same effect as saying C<sub name;>).  If C<create> is not set and the
1789 subroutine does not exist then NULL is returned.
1790
1791 =cut
1792 */
1793
1794 CV*
1795 Perl_get_cv(pTHX_ const char *name, I32 create)
1796 {
1797     GV* gv = gv_fetchpv(name, create, SVt_PVCV);
1798     /* XXX unsafe for threads if eval_owner isn't held */
1799     /* XXX this is probably not what they think they're getting.
1800      * It has the same effect as "sub name;", i.e. just a forward
1801      * declaration! */
1802     if (create && !GvCVu(gv))
1803         return newSUB(start_subparse(FALSE, 0),
1804                       newSVOP(OP_CONST, 0, newSVpv(name,0)),
1805                       Nullop,
1806                       Nullop);
1807     if (gv)
1808         return GvCVu(gv);
1809     return Nullcv;
1810 }
1811
1812 /* Be sure to refetch the stack pointer after calling these routines. */
1813
1814 /*
1815
1816 =head1 Callback Functions
1817
1818 =for apidoc p||call_argv
1819
1820 Performs a callback to the specified Perl sub.  See L<perlcall>.
1821
1822 =cut
1823 */
1824
1825 I32
1826 Perl_call_argv(pTHX_ const char *sub_name, I32 flags, register char **argv)
1827
1828                         /* See G_* flags in cop.h */
1829                         /* null terminated arg list */
1830 {
1831     dSP;
1832
1833     PUSHMARK(SP);
1834     if (argv) {
1835         while (*argv) {
1836             XPUSHs(sv_2mortal(newSVpv(*argv,0)));
1837             argv++;
1838         }
1839         PUTBACK;
1840     }
1841     return call_pv(sub_name, flags);
1842 }
1843
1844 /*
1845 =for apidoc p||call_pv
1846
1847 Performs a callback to the specified Perl sub.  See L<perlcall>.
1848
1849 =cut
1850 */
1851
1852 I32
1853 Perl_call_pv(pTHX_ const char *sub_name, I32 flags)
1854                         /* name of the subroutine */
1855                         /* See G_* flags in cop.h */
1856 {
1857     return call_sv((SV*)get_cv(sub_name, TRUE), flags);
1858 }
1859
1860 /*
1861 =for apidoc p||call_method
1862
1863 Performs a callback to the specified Perl method.  The blessed object must
1864 be on the stack.  See L<perlcall>.
1865
1866 =cut
1867 */
1868
1869 I32
1870 Perl_call_method(pTHX_ const char *methname, I32 flags)
1871                         /* name of the subroutine */
1872                         /* See G_* flags in cop.h */
1873 {
1874     return call_sv(sv_2mortal(newSVpv(methname,0)), flags | G_METHOD);
1875 }
1876
1877 /* May be called with any of a CV, a GV, or an SV containing the name. */
1878 /*
1879 =for apidoc p||call_sv
1880
1881 Performs a callback to the Perl sub whose name is in the SV.  See
1882 L<perlcall>.
1883
1884 =cut
1885 */
1886
1887 I32
1888 Perl_call_sv(pTHX_ SV *sv, I32 flags)
1889                         /* See G_* flags in cop.h */
1890 {
1891     dSP;
1892     LOGOP myop;         /* fake syntax tree node */
1893     UNOP method_op;
1894     I32 oldmark;
1895     volatile I32 retval = 0;
1896     I32 oldscope;
1897     bool oldcatch = CATCH_GET;
1898     int ret;
1899     OP* oldop = PL_op;
1900     dJMPENV;
1901
1902     if (flags & G_DISCARD) {
1903         ENTER;
1904         SAVETMPS;
1905     }
1906
1907     Zero(&myop, 1, LOGOP);
1908     myop.op_next = Nullop;
1909     if (!(flags & G_NOARGS))
1910         myop.op_flags |= OPf_STACKED;
1911     myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
1912                       (flags & G_ARRAY) ? OPf_WANT_LIST :
1913                       OPf_WANT_SCALAR);
1914     SAVEOP();
1915     PL_op = (OP*)&myop;
1916
1917     EXTEND(PL_stack_sp, 1);
1918     *++PL_stack_sp = sv;
1919     oldmark = TOPMARK;
1920     oldscope = PL_scopestack_ix;
1921
1922     if (PERLDB_SUB && PL_curstash != PL_debstash
1923            /* Handle first BEGIN of -d. */
1924           && (PL_DBcv || (PL_DBcv = GvCV(PL_DBsub)))
1925            /* Try harder, since this may have been a sighandler, thus
1926             * curstash may be meaningless. */
1927           && (SvTYPE(sv) != SVt_PVCV || CvSTASH((CV*)sv) != PL_debstash)
1928           && !(flags & G_NODEBUG))
1929         PL_op->op_private |= OPpENTERSUB_DB;
1930
1931     if (flags & G_METHOD) {
1932         Zero(&method_op, 1, UNOP);
1933         method_op.op_next = PL_op;
1934         method_op.op_ppaddr = PL_ppaddr[OP_METHOD];
1935         myop.op_ppaddr = PL_ppaddr[OP_ENTERSUB];
1936         PL_op = (OP*)&method_op;
1937     }
1938
1939     if (!(flags & G_EVAL)) {
1940         CATCH_SET(TRUE);
1941         call_body((OP*)&myop, FALSE);
1942         retval = PL_stack_sp - (PL_stack_base + oldmark);
1943         CATCH_SET(oldcatch);
1944     }
1945     else {
1946         myop.op_other = (OP*)&myop;
1947         PL_markstack_ptr--;
1948         /* we're trying to emulate pp_entertry() here */
1949         {
1950             register PERL_CONTEXT *cx;
1951             I32 gimme = GIMME_V;
1952
1953             ENTER;
1954             SAVETMPS;
1955
1956             push_return(Nullop);
1957             PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), PL_stack_sp);
1958             PUSHEVAL(cx, 0, 0);
1959             PL_eval_root = PL_op;             /* Only needed so that goto works right. */
1960
1961             PL_in_eval = EVAL_INEVAL;
1962             if (flags & G_KEEPERR)
1963                 PL_in_eval |= EVAL_KEEPERR;
1964             else
1965                 sv_setpv(ERRSV,"");
1966         }
1967         PL_markstack_ptr++;
1968
1969 #ifdef PERL_FLEXIBLE_EXCEPTIONS
1970  redo_body:
1971         CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_vcall_body),
1972                     (OP*)&myop, FALSE);
1973 #else
1974         JMPENV_PUSH(ret);
1975 #endif
1976         switch (ret) {
1977         case 0:
1978 #ifndef PERL_FLEXIBLE_EXCEPTIONS
1979  redo_body:
1980             call_body((OP*)&myop, FALSE);
1981 #endif
1982             retval = PL_stack_sp - (PL_stack_base + oldmark);
1983             if (!(flags & G_KEEPERR))
1984                 sv_setpv(ERRSV,"");
1985             break;
1986         case 1:
1987             STATUS_ALL_FAILURE;
1988             /* FALL THROUGH */
1989         case 2:
1990             /* my_exit() was called */
1991             PL_curstash = PL_defstash;
1992             FREETMPS;
1993             JMPENV_POP;
1994             if (PL_statusvalue && !(PL_exit_flags & PERL_EXIT_EXPECTED))
1995                 Perl_croak(aTHX_ "Callback called exit");
1996             my_exit_jump();
1997             /* NOTREACHED */
1998         case 3:
1999             if (PL_restartop) {
2000                 PL_op = PL_restartop;
2001                 PL_restartop = 0;
2002                 goto redo_body;
2003             }
2004             PL_stack_sp = PL_stack_base + oldmark;
2005             if (flags & G_ARRAY)
2006                 retval = 0;
2007             else {
2008                 retval = 1;
2009                 *++PL_stack_sp = &PL_sv_undef;
2010             }
2011             break;
2012         }
2013
2014         if (PL_scopestack_ix > oldscope) {
2015             SV **newsp;
2016             PMOP *newpm;
2017             I32 gimme;
2018             register PERL_CONTEXT *cx;
2019             I32 optype;
2020
2021             POPBLOCK(cx,newpm);
2022             POPEVAL(cx);
2023             pop_return();
2024             PL_curpm = newpm;
2025             LEAVE;
2026         }
2027         JMPENV_POP;
2028     }
2029
2030     if (flags & G_DISCARD) {
2031         PL_stack_sp = PL_stack_base + oldmark;
2032         retval = 0;
2033         FREETMPS;
2034         LEAVE;
2035     }
2036     PL_op = oldop;
2037     return retval;
2038 }
2039
2040 #ifdef PERL_FLEXIBLE_EXCEPTIONS
2041 STATIC void *
2042 S_vcall_body(pTHX_ va_list args)
2043 {
2044     OP *myop = va_arg(args, OP*);
2045     int is_eval = va_arg(args, int);
2046
2047     call_body(myop, is_eval);
2048     return NULL;
2049 }
2050 #endif
2051
2052 STATIC void
2053 S_call_body(pTHX_ OP *myop, int is_eval)
2054 {
2055     if (PL_op == myop) {
2056         if (is_eval)
2057             PL_op = Perl_pp_entereval(aTHX);    /* this doesn't do a POPMARK */
2058         else
2059             PL_op = Perl_pp_entersub(aTHX);     /* this does */
2060     }
2061     if (PL_op)
2062         CALLRUNOPS(aTHX);
2063 }
2064
2065 /* Eval a string. The G_EVAL flag is always assumed. */
2066
2067 /*
2068 =for apidoc p||eval_sv
2069
2070 Tells Perl to C<eval> the string in the SV.
2071
2072 =cut
2073 */
2074
2075 I32
2076 Perl_eval_sv(pTHX_ SV *sv, I32 flags)
2077
2078                         /* See G_* flags in cop.h */
2079 {
2080     dSP;
2081     UNOP myop;          /* fake syntax tree node */
2082     volatile I32 oldmark = SP - PL_stack_base;
2083     volatile I32 retval = 0;
2084     I32 oldscope;
2085     int ret;
2086     OP* oldop = PL_op;
2087     dJMPENV;
2088
2089     if (flags & G_DISCARD) {
2090         ENTER;
2091         SAVETMPS;
2092     }
2093
2094     SAVEOP();
2095     PL_op = (OP*)&myop;
2096     Zero(PL_op, 1, UNOP);
2097     EXTEND(PL_stack_sp, 1);
2098     *++PL_stack_sp = sv;
2099     oldscope = PL_scopestack_ix;
2100
2101     if (!(flags & G_NOARGS))
2102         myop.op_flags = OPf_STACKED;
2103     myop.op_next = Nullop;
2104     myop.op_type = OP_ENTEREVAL;
2105     myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
2106                       (flags & G_ARRAY) ? OPf_WANT_LIST :
2107                       OPf_WANT_SCALAR);
2108     if (flags & G_KEEPERR)
2109         myop.op_flags |= OPf_SPECIAL;
2110
2111 #ifdef PERL_FLEXIBLE_EXCEPTIONS
2112  redo_body:
2113     CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_vcall_body),
2114                 (OP*)&myop, TRUE);
2115 #else
2116     JMPENV_PUSH(ret);
2117 #endif
2118     switch (ret) {
2119     case 0:
2120 #ifndef PERL_FLEXIBLE_EXCEPTIONS
2121  redo_body:
2122         call_body((OP*)&myop,TRUE);
2123 #endif
2124         retval = PL_stack_sp - (PL_stack_base + oldmark);
2125         if (!(flags & G_KEEPERR))
2126             sv_setpv(ERRSV,"");
2127         break;
2128     case 1:
2129         STATUS_ALL_FAILURE;
2130         /* FALL THROUGH */
2131     case 2:
2132         /* my_exit() was called */
2133         PL_curstash = PL_defstash;
2134         FREETMPS;
2135         JMPENV_POP;
2136         if (PL_statusvalue && !(PL_exit_flags & PERL_EXIT_EXPECTED))
2137             Perl_croak(aTHX_ "Callback called exit");
2138         my_exit_jump();
2139         /* NOTREACHED */
2140     case 3:
2141         if (PL_restartop) {
2142             PL_op = PL_restartop;
2143             PL_restartop = 0;
2144             goto redo_body;
2145         }
2146         PL_stack_sp = PL_stack_base + oldmark;
2147         if (flags & G_ARRAY)
2148             retval = 0;
2149         else {
2150             retval = 1;
2151             *++PL_stack_sp = &PL_sv_undef;
2152         }
2153         break;
2154     }
2155
2156     JMPENV_POP;
2157     if (flags & G_DISCARD) {
2158         PL_stack_sp = PL_stack_base + oldmark;
2159         retval = 0;
2160         FREETMPS;
2161         LEAVE;
2162     }
2163     PL_op = oldop;
2164     return retval;
2165 }
2166
2167 /*
2168 =for apidoc p||eval_pv
2169
2170 Tells Perl to C<eval> the given string and return an SV* result.
2171
2172 =cut
2173 */
2174
2175 SV*
2176 Perl_eval_pv(pTHX_ const char *p, I32 croak_on_error)
2177 {
2178     dSP;
2179     SV* sv = newSVpv(p, 0);
2180
2181     eval_sv(sv, G_SCALAR);
2182     SvREFCNT_dec(sv);
2183
2184     SPAGAIN;
2185     sv = POPs;
2186     PUTBACK;
2187
2188     if (croak_on_error && SvTRUE(ERRSV)) {
2189         STRLEN n_a;
2190         Perl_croak(aTHX_ SvPVx(ERRSV, n_a));
2191     }
2192
2193     return sv;
2194 }
2195
2196 /* Require a module. */
2197
2198 /*
2199 =head1 Embedding Functions
2200
2201 =for apidoc p||require_pv
2202
2203 Tells Perl to C<require> the file named by the string argument.  It is
2204 analogous to the Perl code C<eval "require '$file'">.  It's even
2205 implemented that way; consider using load_module instead.
2206
2207 =cut */
2208
2209 void
2210 Perl_require_pv(pTHX_ const char *pv)
2211 {
2212     SV* sv;
2213     dSP;
2214     PUSHSTACKi(PERLSI_REQUIRE);
2215     PUTBACK;
2216     sv = sv_newmortal();
2217     sv_setpv(sv, "require '");
2218     sv_catpv(sv, pv);
2219     sv_catpv(sv, "'");
2220     eval_sv(sv, G_DISCARD);
2221     SPAGAIN;
2222     POPSTACK;
2223 }
2224
2225 void
2226 Perl_magicname(pTHX_ char *sym, char *name, I32 namlen)
2227 {
2228     register GV *gv;
2229
2230     if ((gv = gv_fetchpv(sym,TRUE, SVt_PV)))
2231         sv_magic(GvSV(gv), (SV*)gv, PERL_MAGIC_sv, name, namlen);
2232 }
2233
2234 STATIC void
2235 S_usage(pTHX_ char *name)               /* XXX move this out into a module ? */
2236 {
2237     /* This message really ought to be max 23 lines.
2238      * Removed -h because the user already knows that option. Others? */
2239
2240     static char *usage_msg[] = {
2241 "-0[octal]       specify record separator (\\0, if no argument)",
2242 "-a              autosplit mode with -n or -p (splits $_ into @F)",
2243 "-C              enable native wide character system interfaces",
2244 "-c              check syntax only (runs BEGIN and CHECK blocks)",
2245 "-d[:debugger]   run program under debugger",
2246 "-D[number/list] set debugging flags (argument is a bit mask or alphabets)",
2247 "-e 'command'    one line of program (several -e's allowed, omit programfile)",
2248 "-F/pattern/     split() pattern for -a switch (//'s are optional)",
2249 "-i[extension]   edit <> files in place (makes backup if extension supplied)",
2250 "-Idirectory     specify @INC/#include directory (several -I's allowed)",
2251 "-l[octal]       enable line ending processing, specifies line terminator",
2252 "-[mM][-]module  execute `use/no module...' before executing program",
2253 "-n              assume 'while (<>) { ... }' loop around program",
2254 "-p              assume loop like -n but print line also, like sed",
2255 "-P              run program through C preprocessor before compilation",
2256 "-s              enable rudimentary parsing for switches after programfile",
2257 "-S              look for programfile using PATH environment variable",
2258 "-T              enable tainting checks",
2259 "-t              enable tainting warnings",
2260 "-u              dump core after parsing program",
2261 "-U              allow unsafe operations",
2262 "-v              print version, subversion (includes VERY IMPORTANT perl info)",
2263 "-V[:variable]   print configuration summary (or a single Config.pm variable)",
2264 "-w              enable many useful warnings (RECOMMENDED)",
2265 "-W              enable all warnings",
2266 "-X              disable all warnings",
2267 "-x[directory]   strip off text before #!perl line and perhaps cd to directory",
2268 "\n",
2269 NULL
2270 };
2271     char **p = usage_msg;
2272
2273     PerlIO_printf(PerlIO_stdout(),
2274                   "\nUsage: %s [switches] [--] [programfile] [arguments]",
2275                   name);
2276     while (*p)
2277         PerlIO_printf(PerlIO_stdout(), "\n  %s", *p++);
2278 }
2279
2280 /* convert a string of -D options (or digits) into an int.
2281  * sets *s to point to the char after the options */
2282
2283 #ifdef DEBUGGING
2284 int
2285 Perl_get_debug_opts(pTHX_ char **s)
2286 {
2287     int i = 0;
2288     if (isALPHA(**s)) {
2289         /* if adding extra options, remember to update DEBUG_MASK */
2290         static char debopts[] = "psltocPmfrxu HXDSTRJvC";
2291
2292         for (; isALNUM(**s); (*s)++) {
2293             char *d = strchr(debopts,**s);
2294             if (d)
2295                 i |= 1 << (d - debopts);
2296             else if (ckWARN_d(WARN_DEBUGGING))
2297                 Perl_warner(aTHX_ packWARN(WARN_DEBUGGING),
2298                     "invalid option -D%c\n", **s);
2299         }
2300     }
2301     else {
2302         i = atoi(*s);
2303         for (; isALNUM(**s); (*s)++) ;
2304     }
2305 #  ifdef EBCDIC
2306     if ((i & DEBUG_p_FLAG) && ckWARN_d(WARN_DEBUGGING))
2307         Perl_warner(aTHX_ packWARN(WARN_DEBUGGING),
2308                 "-Dp not implemented on this platform\n");
2309 #  endif
2310     return i;
2311 }
2312 #endif
2313
2314 /* This routine handles any switches that can be given during run */
2315
2316 char *
2317 Perl_moreswitches(pTHX_ char *s)
2318 {
2319     STRLEN numlen;
2320     UV rschar;
2321
2322     switch (*s) {
2323     case '0':
2324     {
2325          I32 flags = 0;
2326
2327          SvREFCNT_dec(PL_rs);
2328          if (s[1] == 'x' && s[2]) {
2329               char *e;
2330               U8 *tmps;
2331
2332               for (s += 2, e = s; *e; e++);
2333               numlen = e - s;
2334               flags = PERL_SCAN_SILENT_ILLDIGIT;
2335               rschar = (U32)grok_hex(s, &numlen, &flags, NULL);
2336               if (s + numlen < e) {
2337                    rschar = 0; /* Grandfather -0xFOO as -0 -xFOO. */
2338                    numlen = 0;
2339                    s--;
2340               }
2341               PL_rs = newSVpvn("", 0);
2342               SvGROW(PL_rs, (STRLEN)(UNISKIP(rschar) + 1));
2343               tmps = (U8*)SvPVX(PL_rs);
2344               uvchr_to_utf8(tmps, rschar);
2345               SvCUR_set(PL_rs, UNISKIP(rschar));
2346               SvUTF8_on(PL_rs);
2347          }
2348          else {
2349               numlen = 4;
2350               rschar = (U32)grok_oct(s, &numlen, &flags, NULL);
2351               if (rschar & ~((U8)~0))
2352                    PL_rs = &PL_sv_undef;
2353               else if (!rschar && numlen >= 2)
2354                    PL_rs = newSVpvn("", 0);
2355               else {
2356                    char ch = (char)rschar;
2357                    PL_rs = newSVpvn(&ch, 1);
2358               }
2359          }
2360          return s + numlen;
2361     }
2362     case 'C':
2363         s++;
2364         PL_unicode = parse_unicode_opts(&s);
2365         return s;
2366     case 'F':
2367         PL_minus_F = TRUE;
2368         PL_splitstr = ++s;
2369         while (*s && !isSPACE(*s)) ++s;
2370         *s = '\0';
2371         PL_splitstr = savepv(PL_splitstr);
2372         return s;
2373     case 'a':
2374         PL_minus_a = TRUE;
2375         s++;
2376         return s;
2377     case 'c':
2378         PL_minus_c = TRUE;
2379         s++;
2380         return s;
2381     case 'd':
2382         forbid_setid("-d");
2383         s++;
2384         /* The following permits -d:Mod to accepts arguments following an =
2385            in the fashion that -MSome::Mod does. */
2386         if (*s == ':' || *s == '=') {
2387             char *start;
2388             SV *sv;
2389             sv = newSVpv("use Devel::", 0);
2390             start = ++s;
2391             /* We now allow -d:Module=Foo,Bar */
2392             while(isALNUM(*s) || *s==':') ++s;
2393             if (*s != '=')
2394                 sv_catpv(sv, start);
2395             else {
2396                 sv_catpvn(sv, start, s-start);
2397                 sv_catpv(sv, " split(/,/,q{");
2398                 sv_catpv(sv, ++s);
2399                 sv_catpv(sv,    "})");
2400             }
2401             s += strlen(s);
2402             my_setenv("PERL5DB", SvPV(sv, PL_na));
2403         }
2404         if (!PL_perldb) {
2405             PL_perldb = PERLDB_ALL;
2406             init_debugger();
2407         }
2408         return s;
2409     case 'D':
2410     {
2411 #ifdef DEBUGGING
2412         forbid_setid("-D");
2413         s++;
2414         PL_debug = get_debug_opts(&s) | DEBUG_TOP_FLAG;
2415 #else /* !DEBUGGING */
2416         if (ckWARN_d(WARN_DEBUGGING))
2417             Perl_warner(aTHX_ packWARN(WARN_DEBUGGING),
2418                    "Recompile perl with -DDEBUGGING to use -D switch\n");
2419         for (s++; isALNUM(*s); s++) ;
2420 #endif
2421         /*SUPPRESS 530*/
2422         return s;
2423     }
2424     case 'h':
2425         usage(PL_origargv[0]);
2426         my_exit(0);
2427     case 'i':
2428         if (PL_inplace)
2429             Safefree(PL_inplace);
2430 #if defined(__CYGWIN__) /* do backup extension automagically */
2431         if (*(s+1) == '\0') {
2432         PL_inplace = savepv(".bak");
2433         return s+1;
2434         }
2435 #endif /* __CYGWIN__ */
2436         PL_inplace = savepv(s+1);
2437         /*SUPPRESS 530*/
2438         for (s = PL_inplace; *s && !isSPACE(*s); s++) ;
2439         if (*s) {
2440             *s++ = '\0';
2441             if (*s == '-')      /* Additional switches on #! line. */
2442                 s++;
2443         }
2444         return s;
2445     case 'I':   /* -I handled both here and in parse_body() */
2446         forbid_setid("-I");
2447         ++s;
2448         while (*s && isSPACE(*s))
2449             ++s;
2450         if (*s) {
2451             char *e, *p;
2452             p = s;
2453             /* ignore trailing spaces (possibly followed by other switches) */
2454             do {
2455                 for (e = p; *e && !isSPACE(*e); e++) ;
2456                 p = e;
2457                 while (isSPACE(*p))
2458                     p++;
2459             } while (*p && *p != '-');
2460             e = savepvn(s, e-s);
2461             incpush(e, TRUE, TRUE, FALSE);
2462             Safefree(e);
2463             s = p;
2464             if (*s == '-')
2465                 s++;
2466         }
2467         else
2468             Perl_croak(aTHX_ "No directory specified for -I");
2469         return s;
2470     case 'l':
2471         PL_minus_l = TRUE;
2472         s++;
2473         if (PL_ors_sv) {
2474             SvREFCNT_dec(PL_ors_sv);
2475             PL_ors_sv = Nullsv;
2476         }
2477         if (isDIGIT(*s)) {
2478             I32 flags = 0;
2479             PL_ors_sv = newSVpvn("\n",1);
2480             numlen = 3 + (*s == '0');
2481             *SvPVX(PL_ors_sv) = (char)grok_oct(s, &numlen, &flags, NULL);
2482             s += numlen;
2483         }
2484         else {
2485             if (RsPARA(PL_rs)) {
2486                 PL_ors_sv = newSVpvn("\n\n",2);
2487             }
2488             else {
2489                 PL_ors_sv = newSVsv(PL_rs);
2490             }
2491         }
2492         return s;
2493     case 'A':
2494         forbid_setid("-A");
2495         if (!PL_preambleav)
2496             PL_preambleav = newAV();
2497         if (*++s) {
2498             SV *sv = newSVpvn("use assertions::activate split(/,/,q{",37);
2499             sv_catpv(sv,s);
2500             sv_catpv(sv,"})");
2501             s+=strlen(s);
2502             av_push(PL_preambleav, sv);
2503         }
2504         else
2505             av_push(PL_preambleav, newSVpvn("use assertions::activate",24));
2506         return s;
2507     case 'M':
2508         forbid_setid("-M");     /* XXX ? */
2509         /* FALL THROUGH */
2510     case 'm':
2511         forbid_setid("-m");     /* XXX ? */
2512         if (*++s) {
2513             char *start;
2514             SV *sv;
2515             char *use = "use ";
2516             /* -M-foo == 'no foo'       */
2517             if (*s == '-') { use = "no "; ++s; }
2518             sv = newSVpv(use,0);
2519             start = s;
2520             /* We allow -M'Module qw(Foo Bar)'  */
2521             while(isALNUM(*s) || *s==':') ++s;
2522             if (*s != '=') {
2523                 sv_catpv(sv, start);
2524                 if (*(start-1) == 'm') {
2525                     if (*s != '\0')
2526                         Perl_croak(aTHX_ "Can't use '%c' after -mname", *s);
2527                     sv_catpv( sv, " ()");
2528                 }
2529             } else {
2530                 if (s == start)
2531                     Perl_croak(aTHX_ "Module name required with -%c option",
2532                                s[-1]);
2533                 sv_catpvn(sv, start, s-start);
2534                 sv_catpv(sv, " split(/,/,q{");
2535                 sv_catpv(sv, ++s);
2536                 sv_catpv(sv,    "})");
2537             }
2538             s += strlen(s);
2539             if (!PL_preambleav)
2540                 PL_preambleav = newAV();
2541             av_push(PL_preambleav, sv);
2542         }
2543         else
2544             Perl_croak(aTHX_ "No space allowed after -%c", *(s-1));
2545         return s;
2546     case 'n':
2547         PL_minus_n = TRUE;
2548         s++;
2549         return s;
2550     case 'p':
2551         PL_minus_p = TRUE;
2552         s++;
2553         return s;
2554     case 's':
2555         forbid_setid("-s");
2556         PL_doswitches = TRUE;
2557         s++;
2558         return s;
2559     case 't':
2560         if (!PL_tainting)
2561             TOO_LATE_FOR('t');
2562         s++;
2563         return s;
2564     case 'T':
2565         if (!PL_tainting)
2566             TOO_LATE_FOR('T');
2567         s++;
2568         return s;
2569     case 'u':
2570 #ifdef MACOS_TRADITIONAL
2571         Perl_croak(aTHX_ "Believe me, you don't want to use \"-u\" on a Macintosh");
2572 #endif
2573         PL_do_undump = TRUE;
2574         s++;
2575         return s;
2576     case 'U':
2577         PL_unsafe = TRUE;
2578         s++;
2579         return s;
2580     case 'v':
2581 #if !defined(DGUX)
2582         PerlIO_printf(PerlIO_stdout(),
2583                       Perl_form(aTHX_ "\nThis is perl, v%"VDf" built for %s",
2584                                 PL_patchlevel, ARCHNAME));
2585 #else /* DGUX */
2586 /* Adjust verbose output as in the perl that ships with the DG/UX OS from EMC */
2587         PerlIO_printf(PerlIO_stdout(),
2588                         Perl_form(aTHX_ "\nThis is perl, version %vd\n", PL_patchlevel));
2589         PerlIO_printf(PerlIO_stdout(),
2590                         Perl_form(aTHX_ "        built under %s at %s %s\n",
2591                                         OSNAME, __DATE__, __TIME__));
2592         PerlIO_printf(PerlIO_stdout(),
2593                         Perl_form(aTHX_ "        OS Specific Release: %s\n",
2594                                         OSVERS));
2595 #endif /* !DGUX */
2596
2597 #if defined(LOCAL_PATCH_COUNT)
2598         if (LOCAL_PATCH_COUNT > 0)
2599             PerlIO_printf(PerlIO_stdout(),
2600                           "\n(with %d registered patch%s, "
2601                           "see perl -V for more detail)",
2602                           (int)LOCAL_PATCH_COUNT,
2603                           (LOCAL_PATCH_COUNT!=1) ? "es" : "");
2604 #endif
2605
2606         PerlIO_printf(PerlIO_stdout(),
2607                       "\n\nCopyright 1987-2003, Larry Wall\n");
2608 #ifdef MACOS_TRADITIONAL
2609         PerlIO_printf(PerlIO_stdout(),
2610                       "\nMac OS port Copyright 1991-2002, Matthias Neeracher;\n"
2611                       "maintained by Chris Nandor\n");
2612 #endif
2613 #ifdef MSDOS
2614         PerlIO_printf(PerlIO_stdout(),
2615                       "\nMS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n");
2616 #endif
2617 #ifdef DJGPP
2618         PerlIO_printf(PerlIO_stdout(),
2619                       "djgpp v2 port (jpl5003c) by Hirofumi Watanabe, 1996\n"
2620                       "djgpp v2 port (perl5004+) by Laszlo Molnar, 1997-1999\n");
2621 #endif
2622 #ifdef OS2
2623         PerlIO_printf(PerlIO_stdout(),
2624                       "\n\nOS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n"
2625                       "Version 5 port Copyright (c) 1994-2002, Andreas Kaiser, Ilya Zakharevich\n");
2626 #endif
2627 #ifdef atarist
2628         PerlIO_printf(PerlIO_stdout(),
2629                       "atariST series port, ++jrb  bammi@cadence.com\n");
2630 #endif
2631 #ifdef __BEOS__
2632         PerlIO_printf(PerlIO_stdout(),
2633                       "BeOS port Copyright Tom Spindler, 1997-1999\n");
2634 #endif
2635 #ifdef MPE
2636         PerlIO_printf(PerlIO_stdout(),
2637                       "MPE/iX port Copyright by Mark Klein and Mark Bixby, 1996-2003\n");
2638 #endif
2639 #ifdef OEMVS
2640         PerlIO_printf(PerlIO_stdout(),
2641                       "MVS (OS390) port by Mortice Kern Systems, 1997-1999\n");
2642 #endif
2643 #ifdef __VOS__
2644         PerlIO_printf(PerlIO_stdout(),
2645                       "Stratus VOS port by Paul.Green@stratus.com, 1997-2002\n");
2646 #endif
2647 #ifdef __OPEN_VM
2648         PerlIO_printf(PerlIO_stdout(),
2649                       "VM/ESA port by Neale Ferguson, 1998-1999\n");
2650 #endif
2651 #ifdef POSIX_BC
2652         PerlIO_printf(PerlIO_stdout(),
2653                       "BS2000 (POSIX) port by Start Amadeus GmbH, 1998-1999\n");
2654 #endif
2655 #ifdef __MINT__
2656         PerlIO_printf(PerlIO_stdout(),
2657                       "MiNT port by Guido Flohr, 1997-1999\n");
2658 #endif
2659 #ifdef EPOC
2660         PerlIO_printf(PerlIO_stdout(),
2661                       "EPOC port by Olaf Flebbe, 1999-2002\n");
2662 #endif
2663 #ifdef UNDER_CE
2664         PerlIO_printf(PerlIO_stdout(),"WINCE port by Rainer Keuchel, 2001-2002\n");
2665         PerlIO_printf(PerlIO_stdout(),"Built on " __DATE__ " " __TIME__ "\n\n");
2666         wce_hitreturn();
2667 #endif
2668 #ifdef BINARY_BUILD_NOTICE
2669         BINARY_BUILD_NOTICE;
2670 #endif
2671         PerlIO_printf(PerlIO_stdout(),
2672                       "\n\
2673 Perl may be copied only under the terms of either the Artistic License or the\n\
2674 GNU General Public License, which may be found in the Perl 5 source kit.\n\n\
2675 Complete documentation for Perl, including FAQ lists, should be found on\n\
2676 this system using `man perl' or `perldoc perl'.  If you have access to the\n\
2677 Internet, point your browser at http://www.perl.com/, the Perl Home Page.\n\n");
2678         my_exit(0);
2679     case 'w':
2680         if (! (PL_dowarn & G_WARN_ALL_MASK))
2681             PL_dowarn |= G_WARN_ON;
2682         s++;
2683         return s;
2684     case 'W':
2685         PL_dowarn = G_WARN_ALL_ON|G_WARN_ON;
2686         if (!specialWARN(PL_compiling.cop_warnings))
2687             SvREFCNT_dec(PL_compiling.cop_warnings);
2688         PL_compiling.cop_warnings = pWARN_ALL ;
2689         s++;
2690         return s;
2691     case 'X':
2692         PL_dowarn = G_WARN_ALL_OFF;
2693         if (!specialWARN(PL_compiling.cop_warnings))
2694             SvREFCNT_dec(PL_compiling.cop_warnings);
2695         PL_compiling.cop_warnings = pWARN_NONE ;
2696         s++;
2697         return s;
2698     case '*':
2699     case ' ':
2700         if (s[1] == '-')        /* Additional switches on #! line. */
2701             return s+2;
2702         break;
2703     case '-':
2704     case 0:
2705 #if defined(WIN32) || !defined(PERL_STRICT_CR)
2706     case '\r':
2707 #endif
2708     case '\n':
2709     case '\t':
2710         break;
2711 #ifdef ALTERNATE_SHEBANG
2712     case 'S':                   /* OS/2 needs -S on "extproc" line. */
2713         break;
2714 #endif
2715     case 'P':
2716         if (PL_preprocess)
2717             return s+1;
2718         /* FALL THROUGH */
2719     default:
2720         Perl_croak(aTHX_ "Can't emulate -%.1s on #! line",s);
2721     }
2722     return Nullch;
2723 }
2724
2725 /* compliments of Tom Christiansen */
2726
2727 /* unexec() can be found in the Gnu emacs distribution */
2728 /* Known to work with -DUNEXEC and using unexelf.c from GNU emacs-20.2 */
2729
2730 void
2731 Perl_my_unexec(pTHX)
2732 {
2733 #ifdef UNEXEC
2734     SV*    prog;
2735     SV*    file;
2736     int    status = 1;
2737     extern int etext;
2738
2739     prog = newSVpv(BIN_EXP, 0);
2740     sv_catpv(prog, "/perl");
2741     file = newSVpv(PL_origfilename, 0);
2742     sv_catpv(file, ".perldump");
2743
2744     unexec(SvPVX(file), SvPVX(prog), &etext, sbrk(0), 0);
2745     /* unexec prints msg to stderr in case of failure */
2746     PerlProc_exit(status);
2747 #else
2748 #  ifdef VMS
2749 #    include <lib$routines.h>
2750      lib$signal(SS$_DEBUG);  /* ssdef.h #included from vmsish.h */
2751 #  else
2752     ABORT();            /* for use with undump */
2753 #  endif
2754 #endif
2755 }
2756
2757 /* initialize curinterp */
2758 STATIC void
2759 S_init_interp(pTHX)
2760 {
2761
2762 #ifdef MULTIPLICITY
2763 #  define PERLVAR(var,type)
2764 #  define PERLVARA(var,n,type)
2765 #  if defined(PERL_IMPLICIT_CONTEXT)
2766 #    if defined(USE_5005THREADS)
2767 #      define PERLVARI(var,type,init)           PERL_GET_INTERP->var = init;
2768 #      define PERLVARIC(var,type,init)  PERL_GET_INTERP->var = init;
2769 #    else /* !USE_5005THREADS */
2770 #      define PERLVARI(var,type,init)           aTHX->var = init;
2771 #      define PERLVARIC(var,type,init)  aTHX->var = init;
2772 #    endif /* USE_5005THREADS */
2773 #  else
2774 #    define PERLVARI(var,type,init)     PERL_GET_INTERP->var = init;
2775 #    define PERLVARIC(var,type,init)    PERL_GET_INTERP->var = init;
2776 #  endif
2777 #  include "intrpvar.h"
2778 #  ifndef USE_5005THREADS
2779 #    include "thrdvar.h"
2780 #  endif
2781 #  undef PERLVAR
2782 #  undef PERLVARA
2783 #  undef PERLVARI
2784 #  undef PERLVARIC
2785 #else
2786 #  define PERLVAR(var,type)
2787 #  define PERLVARA(var,n,type)
2788 #  define PERLVARI(var,type,init)       PL_##var = init;
2789 #  define PERLVARIC(var,type,init)      PL_##var = init;
2790 #  include "intrpvar.h"
2791 #  ifndef USE_5005THREADS
2792 #    include "thrdvar.h"
2793 #  endif
2794 #  undef PERLVAR
2795 #  undef PERLVARA
2796 #  undef PERLVARI
2797 #  undef PERLVARIC
2798 #endif
2799
2800 }
2801
2802 STATIC void
2803 S_init_main_stash(pTHX)
2804 {
2805     GV *gv;
2806
2807     PL_curstash = PL_defstash = newHV();
2808     PL_curstname = newSVpvn("main",4);
2809     gv = gv_fetchpv("main::",TRUE, SVt_PVHV);
2810     SvREFCNT_dec(GvHV(gv));
2811     GvHV(gv) = (HV*)SvREFCNT_inc(PL_defstash);
2812     SvREADONLY_on(gv);
2813     HvNAME(PL_defstash) = savepv("main");
2814     PL_incgv = gv_HVadd(gv_AVadd(gv_fetchpv("INC",TRUE, SVt_PVAV)));
2815     GvMULTI_on(PL_incgv);
2816     PL_hintgv = gv_fetchpv("\010",TRUE, SVt_PV); /* ^H */
2817     GvMULTI_on(PL_hintgv);
2818     PL_defgv = gv_fetchpv("_",TRUE, SVt_PVAV);
2819     PL_errgv = gv_HVadd(gv_fetchpv("@", TRUE, SVt_PV));
2820     GvMULTI_on(PL_errgv);
2821     PL_replgv = gv_fetchpv("\022", TRUE, SVt_PV); /* ^R */
2822     GvMULTI_on(PL_replgv);
2823     (void)Perl_form(aTHX_ "%240s","");  /* Preallocate temp - for immediate signals. */
2824     sv_grow(ERRSV, 240);        /* Preallocate - for immediate signals. */
2825     sv_setpvn(ERRSV, "", 0);
2826     PL_curstash = PL_defstash;
2827     CopSTASH_set(&PL_compiling, PL_defstash);
2828     PL_debstash = GvHV(gv_fetchpv("DB::", GV_ADDMULTI, SVt_PVHV));
2829     PL_globalstash = GvHV(gv_fetchpv("CORE::GLOBAL::", GV_ADDMULTI, SVt_PVHV));
2830     /* We must init $/ before switches are processed. */
2831     sv_setpvn(get_sv("/", TRUE), "\n", 1);
2832 }
2833
2834 STATIC void
2835 S_open_script(pTHX_ char *scriptname, bool dosearch, SV *sv, int *fdscript)
2836 {
2837     char *quote;
2838     char *code;
2839     char *cpp_discard_flag;
2840     char *perl;
2841
2842     *fdscript = -1;
2843
2844     if (PL_e_script) {
2845         PL_origfilename = savepv("-e");
2846     }
2847     else {
2848         /* if find_script() returns, it returns a malloc()-ed value */
2849         PL_origfilename = scriptname = find_script(scriptname, dosearch, NULL, 1);
2850
2851         if (strnEQ(scriptname, "/dev/fd/", 8) && isDIGIT(scriptname[8]) ) {
2852             char *s = scriptname + 8;
2853             *fdscript = atoi(s);
2854             while (isDIGIT(*s))
2855                 s++;
2856             if (*s) {
2857                 scriptname = savepv(s + 1);
2858                 Safefree(PL_origfilename);
2859                 PL_origfilename = scriptname;
2860             }
2861         }
2862     }
2863
2864     CopFILE_free(PL_curcop);
2865     CopFILE_set(PL_curcop, PL_origfilename);
2866     if (strEQ(PL_origfilename,"-"))
2867         scriptname = "";
2868     if (*fdscript >= 0) {
2869         PL_rsfp = PerlIO_fdopen(*fdscript,PERL_SCRIPT_MODE);
2870 #       if defined(HAS_FCNTL) && defined(F_SETFD)
2871             if (PL_rsfp)
2872                 /* ensure close-on-exec */
2873                 fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,1);
2874 #       endif
2875     }
2876     else if (PL_preprocess) {
2877         char *cpp_cfg = CPPSTDIN;
2878         SV *cpp = newSVpvn("",0);
2879         SV *cmd = NEWSV(0,0);
2880
2881         if (strEQ(cpp_cfg, "cppstdin"))
2882             Perl_sv_catpvf(aTHX_ cpp, "%s/", BIN_EXP);
2883         sv_catpv(cpp, cpp_cfg);
2884
2885 #       ifndef VMS
2886             sv_catpvn(sv, "-I", 2);
2887             sv_catpv(sv,PRIVLIB_EXP);
2888 #       endif
2889
2890         DEBUG_P(PerlIO_printf(Perl_debug_log,
2891                               "PL_preprocess: scriptname=\"%s\", cpp=\"%s\", sv=\"%s\", CPPMINUS=\"%s\"\n",
2892                               scriptname, SvPVX (cpp), SvPVX (sv), CPPMINUS));
2893
2894 #       if defined(MSDOS) || defined(WIN32) || defined(VMS)
2895             quote = "\"";
2896 #       else
2897             quote = "'";
2898 #       endif
2899
2900 #       ifdef VMS
2901             cpp_discard_flag = "";
2902 #       else
2903             cpp_discard_flag = "-C";
2904 #       endif
2905
2906 #       ifdef OS2
2907             perl = os2_execname(aTHX);
2908 #       else
2909             perl = PL_origargv[0];
2910 #       endif
2911
2912
2913         /* This strips off Perl comments which might interfere with
2914            the C pre-processor, including #!.  #line directives are
2915            deliberately stripped to avoid confusion with Perl's version
2916            of #line.  FWP played some golf with it so it will fit
2917            into VMS's 255 character buffer.
2918         */
2919         if( PL_doextract )
2920             code = "(1../^#!.*perl/i)|/^\\s*#(?!\\s*((ifn?|un)def|(el|end)?if|define|include|else|error|pragma)\\b)/||!($|=1)||print";
2921         else
2922             code = "/^\\s*#(?!\\s*((ifn?|un)def|(el|end)?if|define|include|else|error|pragma)\\b)/||!($|=1)||print";
2923
2924         Perl_sv_setpvf(aTHX_ cmd, "\
2925 %s -ne%s%s%s %s | %"SVf" %s %"SVf" %s",
2926                        perl, quote, code, quote, scriptname, cpp,
2927                        cpp_discard_flag, sv, CPPMINUS);
2928
2929         PL_doextract = FALSE;
2930 #       ifdef IAMSUID                   /* actually, this is caught earlier */
2931             if (PL_euid != PL_uid && !PL_euid) {  /* if running suidperl */
2932 #               ifdef HAS_SETEUID
2933                     (void)seteuid(PL_uid);        /* musn't stay setuid root */
2934 #               else
2935 #               ifdef HAS_SETREUID
2936                     (void)setreuid((Uid_t)-1, PL_uid);
2937 #               else
2938 #               ifdef HAS_SETRESUID
2939                     (void)setresuid((Uid_t)-1, PL_uid, (Uid_t)-1);
2940 #               else
2941                     PerlProc_setuid(PL_uid);
2942 #               endif
2943 #               endif
2944 #               endif
2945             if (PerlProc_geteuid() != PL_uid)
2946                 Perl_croak(aTHX_ "Can't do seteuid!\n");
2947         }
2948 #       endif /* IAMSUID */
2949
2950         DEBUG_P(PerlIO_printf(Perl_debug_log,
2951                               "PL_preprocess: cmd=\"%s\"\n",
2952                               SvPVX(cmd)));
2953
2954         PL_rsfp = PerlProc_popen(SvPVX(cmd), "r");
2955         SvREFCNT_dec(cmd);
2956         SvREFCNT_dec(cpp);
2957     }
2958     else if (!*scriptname) {
2959         forbid_setid("program input from stdin");
2960         PL_rsfp = PerlIO_stdin();
2961     }
2962     else {
2963         PL_rsfp = PerlIO_open(scriptname,PERL_SCRIPT_MODE);
2964 #       if defined(HAS_FCNTL) && defined(F_SETFD)
2965             if (PL_rsfp)
2966                 /* ensure close-on-exec */
2967                 fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,1);
2968 #       endif
2969     }
2970     if (!PL_rsfp) {
2971 #       ifdef DOSUID
2972 #       ifndef IAMSUID  /* in case script is not readable before setuid */
2973             if (PL_euid &&
2974                 PerlLIO_stat(CopFILE(PL_curcop),&PL_statbuf) >= 0 &&
2975                 PL_statbuf.st_mode & (S_ISUID|S_ISGID))
2976             {
2977                 /* try again */
2978                 PERL_FPU_PRE_EXEC
2979                 PerlProc_execv(Perl_form(aTHX_ "%s/sperl"PERL_FS_VER_FMT,
2980                                          BIN_EXP, (int)PERL_REVISION,
2981                                          (int)PERL_VERSION,
2982                                          (int)PERL_SUBVERSION), PL_origargv);
2983                 PERL_FPU_POST_EXEC
2984                 Perl_croak(aTHX_ "Can't do setuid\n");
2985             }
2986 #       endif
2987 #       endif
2988 #       ifdef IAMSUID
2989             errno = EPERM;
2990             Perl_croak(aTHX_ "Can't open perl script: %s\n",
2991                        Strerror(errno));
2992 #       else
2993             Perl_croak(aTHX_ "Can't open perl script \"%s\": %s\n",
2994                        CopFILE(PL_curcop), Strerror(errno));
2995 #       endif
2996     }
2997 }
2998
2999 /* Mention
3000  * I_SYSSTATVFS HAS_FSTATVFS
3001  * I_SYSMOUNT
3002  * I_STATFS     HAS_FSTATFS     HAS_GETFSSTAT
3003  * I_MNTENT     HAS_GETMNTENT   HAS_HASMNTOPT
3004  * here so that metaconfig picks them up. */
3005
3006 #ifdef IAMSUID
3007 STATIC int
3008 S_fd_on_nosuid_fs(pTHX_ int fd)
3009 {
3010     int check_okay = 0; /* able to do all the required sys/libcalls */
3011     int on_nosuid  = 0; /* the fd is on a nosuid fs */
3012 /*
3013  * Preferred order: fstatvfs(), fstatfs(), ustat()+getmnt(), getmntent().
3014  * fstatvfs() is UNIX98.
3015  * fstatfs() is 4.3 BSD.
3016  * ustat()+getmnt() is pre-4.3 BSD.
3017  * getmntent() is O(number-of-mounted-filesystems) and can hang on
3018  * an irrelevant filesystem while trying to reach the right one.
3019  */
3020
3021 #undef FD_ON_NOSUID_CHECK_OKAY  /* found the syscalls to do the check? */
3022
3023 #   if !defined(FD_ON_NOSUID_CHECK_OKAY) && \
3024         defined(HAS_FSTATVFS)
3025 #   define FD_ON_NOSUID_CHECK_OKAY
3026     struct statvfs stfs;
3027
3028     check_okay = fstatvfs(fd, &stfs) == 0;
3029     on_nosuid  = check_okay && (stfs.f_flag  & ST_NOSUID);
3030 #   endif /* fstatvfs */
3031
3032 #   if !defined(FD_ON_NOSUID_CHECK_OKAY) && \
3033         defined(PERL_MOUNT_NOSUID)      && \
3034         defined(HAS_FSTATFS)            && \
3035         defined(HAS_STRUCT_STATFS)      && \
3036         defined(HAS_STRUCT_STATFS_F_FLAGS)
3037 #   define FD_ON_NOSUID_CHECK_OKAY
3038     struct statfs  stfs;
3039
3040     check_okay = fstatfs(fd, &stfs)  == 0;
3041     on_nosuid  = check_okay && (stfs.f_flags & PERL_MOUNT_NOSUID);
3042 #   endif /* fstatfs */
3043
3044 #   if !defined(FD_ON_NOSUID_CHECK_OKAY) && \
3045         defined(PERL_MOUNT_NOSUID)      && \
3046         defined(HAS_FSTAT)              && \
3047         defined(HAS_USTAT)              && \
3048         defined(HAS_GETMNT)             && \
3049         defined(HAS_STRUCT_FS_DATA)     && \
3050         defined(NOSTAT_ONE)
3051 #   define FD_ON_NOSUID_CHECK_OKAY
3052     Stat_t fdst;
3053
3054     if (fstat(fd, &fdst) == 0) {
3055         struct ustat us;
3056         if (ustat(fdst.st_dev, &us) == 0) {
3057             struct fs_data fsd;
3058             /* NOSTAT_ONE here because we're not examining fields which
3059              * vary between that case and STAT_ONE. */
3060             if (getmnt((int*)0, &fsd, (int)0, NOSTAT_ONE, us.f_fname) == 0) {
3061                 size_t cmplen = sizeof(us.f_fname);
3062                 if (sizeof(fsd.fd_req.path) < cmplen)
3063                     cmplen = sizeof(fsd.fd_req.path);
3064                 if (strnEQ(fsd.fd_req.path, us.f_fname, cmplen) &&
3065                     fdst.st_dev == fsd.fd_req.dev) {
3066                         check_okay = 1;
3067                         on_nosuid = fsd.fd_req.flags & PERL_MOUNT_NOSUID;
3068                     }
3069                 }
3070             }
3071         }
3072     }
3073 #   endif /* fstat+ustat+getmnt */
3074
3075 #   if !defined(FD_ON_NOSUID_CHECK_OKAY) && \
3076         defined(HAS_GETMNTENT)          && \
3077         defined(HAS_HASMNTOPT)          && \
3078         defined(MNTOPT_NOSUID)
3079 #   define FD_ON_NOSUID_CHECK_OKAY
3080     FILE                *mtab = fopen("/etc/mtab", "r");
3081     struct mntent       *entry;
3082     Stat_t              stb, fsb;
3083
3084     if (mtab && (fstat(fd, &stb) == 0)) {
3085         while (entry = getmntent(mtab)) {
3086             if (stat(entry->mnt_dir, &fsb) == 0
3087                 && fsb.st_dev == stb.st_dev)
3088             {
3089                 /* found the filesystem */
3090                 check_okay = 1;
3091                 if (hasmntopt(entry, MNTOPT_NOSUID))
3092                     on_nosuid = 1;
3093                 break;
3094             } /* A single fs may well fail its stat(). */
3095         }
3096     }
3097     if (mtab)
3098         fclose(mtab);
3099 #   endif /* getmntent+hasmntopt */
3100
3101     if (!check_okay)
3102         Perl_croak(aTHX_ "Can't check filesystem of script \"%s\" for nosuid", PL_origfilename);
3103     return on_nosuid;
3104 }
3105 #endif /* IAMSUID */
3106
3107 STATIC void
3108 S_validate_suid(pTHX_ char *validarg, char *scriptname, int fdscript)
3109 {
3110 #ifdef IAMSUID
3111     int which;
3112 #endif
3113
3114     /* do we need to emulate setuid on scripts? */
3115
3116     /* This code is for those BSD systems that have setuid #! scripts disabled
3117      * in the kernel because of a security problem.  Merely defining DOSUID
3118      * in perl will not fix that problem, but if you have disabled setuid
3119      * scripts in the kernel, this will attempt to emulate setuid and setgid
3120      * on scripts that have those now-otherwise-useless bits set.  The setuid
3121      * root version must be called suidperl or sperlN.NNN.  If regular perl
3122      * discovers that it has opened a setuid script, it calls suidperl with
3123      * the same argv that it had.  If suidperl finds that the script it has
3124      * just opened is NOT setuid root, it sets the effective uid back to the
3125      * uid.  We don't just make perl setuid root because that loses the
3126      * effective uid we had before invoking perl, if it was different from the
3127      * uid.
3128      *
3129      * DOSUID must be defined in both perl and suidperl, and IAMSUID must
3130      * be defined in suidperl only.  suidperl must be setuid root.  The
3131      * Configure script will set this up for you if you want it.
3132      */
3133
3134 #ifdef DOSUID
3135     char *s, *s2;
3136
3137     if (PerlLIO_fstat(PerlIO_fileno(PL_rsfp),&PL_statbuf) < 0)  /* normal stat is insecure */
3138         Perl_croak(aTHX_ "Can't stat script \"%s\"",PL_origfilename);
3139     if (fdscript < 0 && PL_statbuf.st_mode & (S_ISUID|S_ISGID)) {
3140         I32 len;
3141         STRLEN n_a;
3142
3143 #ifdef IAMSUID
3144 #ifndef HAS_SETREUID
3145         /* On this access check to make sure the directories are readable,
3146          * there is actually a small window that the user could use to make
3147          * filename point to an accessible directory.  So there is a faint
3148          * chance that someone could execute a setuid script down in a
3149          * non-accessible directory.  I don't know what to do about that.
3150          * But I don't think it's too important.  The manual lies when
3151          * it says access() is useful in setuid programs.
3152          */
3153         if (PerlLIO_access(CopFILE(PL_curcop),1)) /*double check*/
3154             Perl_croak(aTHX_ "Permission denied");
3155 #else
3156         /* If we can swap euid and uid, then we can determine access rights
3157          * with a simple stat of the file, and then compare device and
3158          * inode to make sure we did stat() on the same file we opened.
3159          * Then we just have to make sure he or she can execute it.
3160          */
3161         {
3162             Stat_t tmpstatbuf;
3163
3164             if (
3165 #ifdef HAS_SETREUID
3166                 setreuid(PL_euid,PL_uid) < 0
3167 #else
3168 # if HAS_SETRESUID
3169                 setresuid(PL_euid,PL_uid,(Uid_t)-1) < 0
3170 # endif
3171 #endif
3172                 || PerlProc_getuid() != PL_euid || PerlProc_geteuid() != PL_uid)
3173                 Perl_croak(aTHX_ "Can't swap uid and euid");    /* really paranoid */
3174             if (PerlLIO_stat(CopFILE(PL_curcop),&tmpstatbuf) < 0)
3175                 Perl_croak(aTHX_ "Permission denied");  /* testing full pathname here */
3176 #if defined(IAMSUID) && !defined(NO_NOSUID_CHECK)
3177             if (fd_on_nosuid_fs(PerlIO_fileno(PL_rsfp)))
3178                 Perl_croak(aTHX_ "Permission denied");
3179 #endif
3180             if (tmpstatbuf.st_dev != PL_statbuf.st_dev ||
3181                 tmpstatbuf.st_ino != PL_statbuf.st_ino) {
3182                 (void)PerlIO_close(PL_rsfp);
3183                 Perl_croak(aTHX_ "Permission denied\n");
3184             }
3185             if (
3186 #ifdef HAS_SETREUID
3187               setreuid(PL_uid,PL_euid) < 0
3188 #else
3189 # if defined(HAS_SETRESUID)
3190               setresuid(PL_uid,PL_euid,(Uid_t)-1) < 0
3191 # endif
3192 #endif
3193               || PerlProc_getuid() != PL_uid || PerlProc_geteuid() != PL_euid)
3194                 Perl_croak(aTHX_ "Can't reswap uid and euid");
3195             if (!cando(S_IXUSR,FALSE,&PL_statbuf))              /* can real uid exec? */
3196                 Perl_croak(aTHX_ "Permission denied\n");
3197         }
3198 #endif /* HAS_SETREUID */
3199 #endif /* IAMSUID */
3200
3201         if (!S_ISREG(PL_statbuf.st_mode))
3202             Perl_croak(aTHX_ "Permission denied");
3203         if (PL_statbuf.st_mode & S_IWOTH)
3204             Perl_croak(aTHX_ "Setuid/gid script is writable by world");
3205         PL_doswitches = FALSE;          /* -s is insecure in suid */
3206         CopLINE_inc(PL_curcop);
3207         if (sv_gets(PL_linestr, PL_rsfp, 0) == Nullch ||
3208           strnNE(SvPV(PL_linestr,n_a),"#!",2) ) /* required even on Sys V */
3209             Perl_croak(aTHX_ "No #! line");
3210         s = SvPV(PL_linestr,n_a)+2;
3211         if (*s == ' ') s++;
3212         while (!isSPACE(*s)) s++;
3213         for (s2 = s;  (s2 > SvPV(PL_linestr,n_a)+2 &&
3214                        (isDIGIT(s2[-1]) || strchr("._-", s2[-1])));  s2--) ;
3215         if (strnNE(s2-4,"perl",4) && strnNE(s-9,"perl",4))  /* sanity check */
3216             Perl_croak(aTHX_ "Not a perl script");
3217         while (*s == ' ' || *s == '\t') s++;
3218         /*
3219          * #! arg must be what we saw above.  They can invoke it by
3220          * mentioning suidperl explicitly, but they may not add any strange
3221          * arguments beyond what #! says if they do invoke suidperl that way.
3222          */
3223         len = strlen(validarg);
3224         if (strEQ(validarg," PHOOEY ") ||
3225             strnNE(s,validarg,len) || !isSPACE(s[len]))
3226             Perl_croak(aTHX_ "Args must match #! line");
3227
3228 #ifndef IAMSUID
3229         if (PL_euid != PL_uid && (PL_statbuf.st_mode & S_ISUID) &&
3230             PL_euid == PL_statbuf.st_uid)
3231             if (!PL_do_undump)
3232                 Perl_croak(aTHX_ "YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
3233 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
3234 #endif /* IAMSUID */
3235
3236         if (PL_euid) {  /* oops, we're not the setuid root perl */
3237             (void)PerlIO_close(PL_rsfp);
3238 #ifndef IAMSUID
3239             /* try again */
3240             PERL_FPU_PRE_EXEC
3241             PerlProc_execv(Perl_form(aTHX_ "%s/sperl"PERL_FS_VER_FMT, BIN_EXP,
3242                                      (int)PERL_REVISION, (int)PERL_VERSION,
3243                                      (int)PERL_SUBVERSION), PL_origargv);
3244             PERL_FPU_POST_EXEC
3245 #endif
3246             Perl_croak(aTHX_ "Can't do setuid\n");
3247         }
3248
3249         if (PL_statbuf.st_mode & S_ISGID && PL_statbuf.st_gid != PL_egid) {
3250 #ifdef HAS_SETEGID
3251             (void)setegid(PL_statbuf.st_gid);
3252 #else
3253 #ifdef HAS_SETREGID
3254            (void)setregid((Gid_t)-1,PL_statbuf.st_gid);
3255 #else
3256 #ifdef HAS_SETRESGID
3257            (void)setresgid((Gid_t)-1,PL_statbuf.st_gid,(Gid_t)-1);
3258 #else
3259             PerlProc_setgid(PL_statbuf.st_gid);
3260 #endif
3261 #endif
3262 #endif
3263             if (PerlProc_getegid() != PL_statbuf.st_gid)
3264                 Perl_croak(aTHX_ "Can't do setegid!\n");
3265         }
3266         if (PL_statbuf.st_mode & S_ISUID) {
3267             if (PL_statbuf.st_uid != PL_euid)
3268 #ifdef HAS_SETEUID
3269                 (void)seteuid(PL_statbuf.st_uid);       /* all that for this */
3270 #else
3271 #ifdef HAS_SETREUID
3272                 (void)setreuid((Uid_t)-1,PL_statbuf.st_uid);
3273 #else
3274 #ifdef HAS_SETRESUID
3275                 (void)setresuid((Uid_t)-1,PL_statbuf.st_uid,(Uid_t)-1);
3276 #else
3277                 PerlProc_setuid(PL_statbuf.st_uid);
3278 #endif
3279 #endif
3280 #endif
3281             if (PerlProc_geteuid() != PL_statbuf.st_uid)
3282                 Perl_croak(aTHX_ "Can't do seteuid!\n");
3283         }
3284         else if (PL_uid) {                      /* oops, mustn't run as root */
3285 #ifdef HAS_SETEUID
3286           (void)seteuid((Uid_t)PL_uid);
3287 #else
3288 #ifdef HAS_SETREUID
3289           (void)setreuid((Uid_t)-1,(Uid_t)PL_uid);
3290 #else
3291 #ifdef HAS_SETRESUID
3292           (void)setresuid((Uid_t)-1,(Uid_t)PL_uid,(Uid_t)-1);
3293 #else
3294           PerlProc_setuid((Uid_t)PL_uid);
3295 #endif
3296 #endif
3297 #endif
3298             if (PerlProc_geteuid() != PL_uid)
3299                 Perl_croak(aTHX_ "Can't do seteuid!\n");
3300         }
3301         init_ids();
3302         if (!cando(S_IXUSR,TRUE,&PL_statbuf))
3303             Perl_croak(aTHX_ "Permission denied\n");    /* they can't do this */
3304     }
3305 #ifdef IAMSUID
3306     else if (PL_preprocess)
3307         Perl_croak(aTHX_ "-P not allowed for setuid/setgid script\n");
3308     else if (fdscript >= 0)
3309         Perl_croak(aTHX_ "fd script not allowed in suidperl\n");
3310     else
3311         Perl_croak(aTHX_ "Script is not setuid/setgid in suidperl\n");
3312
3313     /* We absolutely must clear out any saved ids here, so we */
3314     /* exec the real perl, substituting fd script for scriptname. */
3315     /* (We pass script name as "subdir" of fd, which perl will grok.) */
3316     PerlIO_rewind(PL_rsfp);
3317     PerlLIO_lseek(PerlIO_fileno(PL_rsfp),(Off_t)0,0);  /* just in case rewind didn't */
3318     for (which = 1; PL_origargv[which] && PL_origargv[which] != scriptname; which++) ;
3319     if (!PL_origargv[which])
3320         Perl_croak(aTHX_ "Permission denied");
3321     PL_origargv[which] = savepv(Perl_form(aTHX_ "/dev/fd/%d/%s",
3322                                   PerlIO_fileno(PL_rsfp), PL_origargv[which]));
3323 #if defined(HAS_FCNTL) && defined(F_SETFD)
3324     fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,0);    /* ensure no close-on-exec */
3325 #endif
3326     PERL_FPU_PRE_EXEC
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_FPU_POST_EXEC
3331     Perl_croak(aTHX_ "Can't do setuid\n");
3332 #endif /* IAMSUID */
3333 #else /* !DOSUID */
3334     if (PL_euid != PL_uid || PL_egid != PL_gid) {       /* (suidperl doesn't exist, in fact) */
3335 #ifndef SETUID_SCRIPTS_ARE_SECURE_NOW
3336         PerlLIO_fstat(PerlIO_fileno(PL_rsfp),&PL_statbuf);      /* may be either wrapped or real suid */
3337         if ((PL_euid != PL_uid && PL_euid == PL_statbuf.st_uid && PL_statbuf.st_mode & S_ISUID)
3338             ||
3339             (PL_egid != PL_gid && PL_egid == PL_statbuf.st_gid && PL_statbuf.st_mode & S_ISGID)
3340            )
3341             if (!PL_do_undump)
3342                 Perl_croak(aTHX_ "YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
3343 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
3344 #endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
3345         /* not set-id, must be wrapped */
3346     }
3347 #endif /* DOSUID */
3348 }
3349
3350 STATIC void
3351 S_find_beginning(pTHX)
3352 {
3353     register char *s, *s2;
3354 #ifdef MACOS_TRADITIONAL
3355     int maclines = 0;
3356 #endif
3357
3358     /* skip forward in input to the real script? */
3359
3360     forbid_setid("-x");
3361 #ifdef MACOS_TRADITIONAL
3362     /* Since the Mac OS does not honor #! arguments for us, we do it ourselves */
3363
3364     while (PL_doextract || gMacPerl_AlwaysExtract) {
3365         if ((s = sv_gets(PL_linestr, PL_rsfp, 0)) == Nullch) {
3366             if (!gMacPerl_AlwaysExtract)
3367                 Perl_croak(aTHX_ "No Perl script found in input\n");
3368
3369             if (PL_doextract)                   /* require explicit override ? */
3370                 if (!OverrideExtract(PL_origfilename))
3371                     Perl_croak(aTHX_ "User aborted script\n");
3372                 else
3373                     PL_doextract = FALSE;
3374
3375             /* Pater peccavi, file does not have #! */
3376             PerlIO_rewind(PL_rsfp);
3377
3378             break;
3379         }
3380 #else
3381     while (PL_doextract) {
3382         if ((s = sv_gets(PL_linestr, PL_rsfp, 0)) == Nullch)
3383             Perl_croak(aTHX_ "No Perl script found in input\n");
3384 #endif
3385         s2 = s;
3386         if (*s == '#' && s[1] == '!' && ((s = instr(s,"perl")) || (s = instr(s2,"PERL")))) {
3387             PerlIO_ungetc(PL_rsfp, '\n');               /* to keep line count right */
3388             PL_doextract = FALSE;
3389             while (*s && !(isSPACE (*s) || *s == '#')) s++;
3390             s2 = s;
3391             while (*s == ' ' || *s == '\t') s++;
3392             if (*s++ == '-') {
3393                 while (isDIGIT(s2[-1]) || strchr("-._", s2[-1])) s2--;
3394                 if (strnEQ(s2-4,"perl",4))
3395                     /*SUPPRESS 530*/
3396                     while ((s = moreswitches(s)))
3397                         ;
3398             }
3399 #ifdef MACOS_TRADITIONAL
3400             /* We are always searching for the #!perl line in MacPerl,
3401              * so if we find it, still keep the line count correct
3402              * by counting lines we already skipped over
3403              */
3404             for (; maclines > 0 ; maclines--)
3405                 PerlIO_ungetc(PL_rsfp, '\n');
3406
3407             break;
3408
3409         /* gMacPerl_AlwaysExtract is false in MPW tool */
3410         } else if (gMacPerl_AlwaysExtract) {
3411             ++maclines;
3412 #endif
3413         }
3414     }
3415 }
3416
3417
3418 STATIC void
3419 S_init_ids(pTHX)
3420 {
3421     PL_uid = PerlProc_getuid();
3422     PL_euid = PerlProc_geteuid();
3423     PL_gid = PerlProc_getgid();
3424     PL_egid = PerlProc_getegid();
3425 #ifdef VMS
3426     PL_uid |= PL_gid << 16;
3427     PL_euid |= PL_egid << 16;
3428 #endif
3429     /* Should not happen: */
3430     CHECK_MALLOC_TAINT(PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
3431     PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
3432 }
3433
3434 /* This is used very early in the lifetime of the program,
3435  * before even the options are parsed, so PL_tainting has
3436  * not been initialized properly.  */
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("DB::args", GV_ADDMULTI, SVt_PVAV))));
3486     AvREAL_off(PL_dbargs);
3487     PL_DBgv = gv_fetchpv("DB::DB", GV_ADDMULTI, SVt_PVGV);
3488     PL_DBline = gv_fetchpv("DB::dbline", GV_ADDMULTI, SVt_PVAV);
3489     PL_DBsub = gv_HVadd(gv_fetchpv("DB::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("DB::single", GV_ADDMULTI, SVt_PV)));
3492     sv_setiv(PL_DBsingle, 0);
3493     PL_DBtrace = GvSV((gv_fetchpv("DB::trace", GV_ADDMULTI, SVt_PV)));
3494     sv_setiv(PL_DBtrace, 0);
3495     PL_DBsignal = GvSV((gv_fetchpv("DB::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 }