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