perl.c

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