perl.c

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