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