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