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