perl.c

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