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