perl.c

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