perl.c

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