perl.c

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