perl.c

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