perl.c

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