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