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