perl.c

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