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