perl.c

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