perl.c

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