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