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