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