perl.c

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