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