perl.c

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