perl.c

   1 /*    perl.c
   2  *
   3  *    Copyright (c) 1987-2002 Larry Wall
   4  *
   5  *    You may distribute under the terms of either the GNU General Public
   6  *    License or the Artistic License, as specified in the README file.
   7  *
   8  */
   9
  10 /*
  11  * "A ship then new they built for him/of mithril and of elven glass" --Bilbo
  12  */
  13
  14 #include "EXTERN.h"
  15 #define PERL_IN_PERL_C
  16 #include "perl.h"
  17 #include "patchlevel.h"                 /* for local_patches */
  18
  19 #ifdef NETWARE
  20 #include "nwutil.h"
  21 char *nw_get_sitelib(const char *pl);
  22 #endif
  23
  24 /* XXX If this causes problems, set i_unistd=undef in the hint file.  */
  25 #ifdef I_UNISTD
  26 #include <unistd.h>
  27 #endif
  28
  29 #ifdef __BEOS__
  30 #  define HZ 1000000
  31 #endif
  32
  33 #ifndef HZ
  34 #  ifdef CLK_TCK
  35 #    define HZ CLK_TCK
  36 #  else
  37 #    define HZ 60
  38 #  endif
  39 #endif
  40
  41 #if !defined(STANDARD_C) && !defined(HAS_GETENV_PROTOTYPE) && !defined(PERL_MICRO)
  42 char *getenv (char *); /* Usually in <stdlib.h> */
  43 #endif
  44
  45 static I32 read_e_script(pTHX_ int idx, SV *buf_sv, int maxlen);
  46
  47 #ifdef IAMSUID
  48 #ifndef DOSUID
  49 #define DOSUID
  50 #endif
  51 #endif
  52
  53 #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
  54 #ifdef DOSUID
  55 #undef DOSUID
  56 #endif
  57 #endif
  58
  59 #if defined(USE_ITHREADS)
  60 #  define INIT_TLS_AND_INTERP \
  61     STMT_START {                                \
  62         if (!PL_curinterp) {                    \
  63             PERL_SET_INTERP(my_perl);           \
  64             INIT_THREADS;                       \
  65             ALLOC_THREAD_KEY;                   \
  66             PERL_SET_THX(my_perl);              \
  67             OP_REFCNT_INIT;                     \
  68         }                                       \
  69         else {                                  \
  70             PERL_SET_THX(my_perl);              \
  71         }                                       \
  72     } STMT_END
  73 #else
  74 #  define INIT_TLS_AND_INTERP \
  75     STMT_START {                                \
  76         if (!PL_curinterp) {                    \
  77             PERL_SET_INTERP(my_perl);           \
  78         }                                       \
  79         PERL_SET_THX(my_perl);                  \
  80     } STMT_END
  81 #  endif
  82
  83 #ifdef PERL_IMPLICIT_SYS
  84 PerlInterpreter *
  85 perl_alloc_using(struct IPerlMem* ipM, struct IPerlMem* ipMS,
  86                  struct IPerlMem* ipMP, struct IPerlEnv* ipE,
  87                  struct IPerlStdIO* ipStd, struct IPerlLIO* ipLIO,
  88                  struct IPerlDir* ipD, struct IPerlSock* ipS,
  89                  struct IPerlProc* ipP)
  90 {
  91     PerlInterpreter *my_perl;
  92     /* New() needs interpreter, so call malloc() instead */
  93     my_perl = (PerlInterpreter*)(*ipM->pMalloc)(ipM, sizeof(PerlInterpreter));
  94     INIT_TLS_AND_INTERP;
  95     Zero(my_perl, 1, PerlInterpreter);
  96     PL_Mem = ipM;
  97     PL_MemShared = ipMS;
  98     PL_MemParse = ipMP;
  99     PL_Env = ipE;
 100     PL_StdIO = ipStd;
 101     PL_LIO = ipLIO;
 102     PL_Dir = ipD;
 103     PL_Sock = ipS;
 104     PL_Proc = ipP;
 105
 106     return my_perl;
 107 }
 108 #else
 109
 110 /*
 111 =head1 Embedding Functions
 112
 113 =for apidoc perl_alloc
 114
 115 Allocates a new Perl interpreter.  See L<perlembed>.
 116
 117 =cut
 118 */
 119
 120 PerlInterpreter *
 121 perl_alloc(void)
 122 {
 123     PerlInterpreter *my_perl;
 124 #ifdef USE_5005THREADS
 125     dTHX;
 126 #endif
 127
 128     /* New() needs interpreter, so call malloc() instead */
 129     my_perl = (PerlInterpreter*)PerlMem_malloc(sizeof(PerlInterpreter));
 130
 131     INIT_TLS_AND_INTERP;
 132     Zero(my_perl, 1, PerlInterpreter);
 133     return my_perl;
 134 }
 135 #endif /* PERL_IMPLICIT_SYS */
 136
 137 /*
 138 =for apidoc perl_construct
 139
 140 Initializes a new Perl interpreter.  See L<perlembed>.
 141
 142 =cut
 143 */
 144
 145 void
 146 perl_construct(pTHXx)
 147 {
 148 #ifdef MULTIPLICITY
 149     init_interp();
 150     PL_perl_destruct_level = 1;
 151 #else
 152    if (PL_perl_destruct_level > 0)
 153        init_interp();
 154 #endif
 155
 156    /* Init the real globals (and main thread)? */
 157     if (!PL_linestr) {
 158 #ifdef PERL_FLEXIBLE_EXCEPTIONS
 159         PL_protect = MEMBER_TO_FPTR(Perl_default_protect); /* for exceptions */
 160 #endif
 161
 162         PL_curcop = &PL_compiling;      /* needed by ckWARN, right away */
 163
 164         PL_linestr = NEWSV(65,79);
 165         sv_upgrade(PL_linestr,SVt_PVIV);
 166
 167         if (!SvREADONLY(&PL_sv_undef)) {
 168             /* set read-only and try to insure than we wont see REFCNT==0
 169                very often */
 170
 171             SvREADONLY_on(&PL_sv_undef);
 172             SvREFCNT(&PL_sv_undef) = (~(U32)0)/2;
 173
 174             sv_setpv(&PL_sv_no,PL_No);
 175             SvNV(&PL_sv_no);
 176             SvREADONLY_on(&PL_sv_no);
 177             SvREFCNT(&PL_sv_no) = (~(U32)0)/2;
 178
 179             sv_setpv(&PL_sv_yes,PL_Yes);
 180             SvNV(&PL_sv_yes);
 181             SvREADONLY_on(&PL_sv_yes);
 182             SvREFCNT(&PL_sv_yes) = (~(U32)0)/2;
 183         }
 184
 185         PL_sighandlerp = Perl_sighandler;
 186         PL_pidstatus = newHV();
 187     }
 188
 189     PL_rs = newSVpvn("\n", 1);
 190
 191     init_stacks();
 192
 193     init_ids();
 194     PL_lex_state = LEX_NOTPARSING;
 195
 196     JMPENV_BOOTSTRAP;
 197     STATUS_ALL_SUCCESS;
 198
 199     init_i18nl10n(1);
 200     SET_NUMERIC_STANDARD();
 201
 202     {
 203         U8 *s;
 204         PL_patchlevel = NEWSV(0,4);
 205         (void)SvUPGRADE(PL_patchlevel, SVt_PVNV);
 206         if (PERL_REVISION > 127 || PERL_VERSION > 127 || PERL_SUBVERSION > 127)
 207             SvGROW(PL_patchlevel, UTF8_MAXLEN*3+1);
 208         s = (U8*)SvPVX(PL_patchlevel);
 209         /* Build version strings using "native" characters */
 210         s = uvchr_to_utf8(s, (UV)PERL_REVISION);
 211         s = uvchr_to_utf8(s, (UV)PERL_VERSION);
 212         s = uvchr_to_utf8(s, (UV)PERL_SUBVERSION);
 213         *s = '\0';
 214         SvCUR_set(PL_patchlevel, s - (U8*)SvPVX(PL_patchlevel));
 215         SvPOK_on(PL_patchlevel);
 216         SvNVX(PL_patchlevel) = (NV)PERL_REVISION
 217                                 + ((NV)PERL_VERSION / (NV)1000)
 218 #if defined(PERL_SUBVERSION) && PERL_SUBVERSION > 0
 219                                 + ((NV)PERL_SUBVERSION / (NV)1000000)
 220 #endif
 221                                 ;
 222         SvNOK_on(PL_patchlevel);        /* dual valued */
 223         SvUTF8_on(PL_patchlevel);
 224         SvREADONLY_on(PL_patchlevel);
 225     }
 226
 227 #if defined(LOCAL_PATCH_COUNT)
 228     PL_localpatches = local_patches;    /* For possible -v */
 229 #endif
 230
 231 #ifdef HAVE_INTERP_INTERN
 232     sys_intern_init();
 233 #endif
 234
 235     PerlIO_init(aTHX);                  /* Hook to IO system */
 236
 237     PL_fdpid = newAV();                 /* for remembering popen pids by fd */
 238     PL_modglobal = newHV();             /* pointers to per-interpreter module globals */
 239     PL_errors = newSVpvn("",0);
 240     sv_setpvn(PERL_DEBUG_PAD(0), "", 0);        /* For regex debugging. */
 241     sv_setpvn(PERL_DEBUG_PAD(1), "", 0);        /* ext/re needs these */
 242     sv_setpvn(PERL_DEBUG_PAD(2), "", 0);        /* even without DEBUGGING. */
 243 #ifdef USE_ITHREADS
 244     PL_regex_padav = newAV();
 245     av_push(PL_regex_padav,(SV*)newAV());    /* First entry is an array of empty elements */
 246     PL_regex_pad = AvARRAY(PL_regex_padav);
 247 #endif
 248 #ifdef USE_REENTRANT_API
 249     Perl_reentrant_init(aTHX);
 250 #endif
 251
 252     /* Note that strtab is a rather special HV.  Assumptions are made
 253        about not iterating on it, and not adding tie magic to it.
 254        It is properly deallocated in perl_destruct() */
 255     PL_strtab = newHV();
 256
 257     HvSHAREKEYS_off(PL_strtab);                 /* mandatory */
 258     hv_ksplit(PL_strtab, 512);
 259
 260 #if defined(__DYNAMIC__) && (defined(NeXT) || defined(__NeXT__))
 261     _dyld_lookup_and_bind
 262         ("__environ", (unsigned long *) &environ_pointer, NULL);
 263 #endif /* environ */
 264
 265 #ifdef  USE_ENVIRON_ARRAY
 266     PL_origenviron = environ;
 267 #endif
 268
 269     /* Use sysconf(_SC_CLK_TCK) if available, if not
 270      * available or if the sysconf() fails, use the HZ. */
 271 #if defined(HAS_SYSCONF) && defined(_SC_CLK_TCK)
 272     PL_clocktick = sysconf(_SC_CLK_TCK);
 273     if (PL_clocktick <= 0)
 274 #endif
 275          PL_clocktick = HZ;
 276
 277     ENTER;
 278 }
 279
 280 /*
 281 =for apidoc nothreadhook
 282
 283 Stub that provides thread hook for perl_destruct when there are
 284 no threads.
 285
 286 =cut
 287 */
 288
 289 int
 290 Perl_nothreadhook(pTHX)
 291 {
 292     return 0;
 293 }
 294
 295 /*
 296 =for apidoc perl_destruct
 297
 298 Shuts down a Perl interpreter.  See L<perlembed>.
 299
 300 =cut
 301 */
 302
 303 int
 304 perl_destruct(pTHXx)
 305 {
 306     volatile int destruct_level;  /* 0=none, 1=full, 2=full with checks */
 307     HV *hv;
 308 #ifdef USE_5005THREADS
 309     dTHX;
 310 #endif /* USE_5005THREADS */
 311
 312     /* wait for all pseudo-forked children to finish */
 313     PERL_WAIT_FOR_CHILDREN;
 314
 315     destruct_level = PL_perl_destruct_level;
 316 #ifdef DEBUGGING
 317     {
 318         char *s;
 319         if ((s = PerlEnv_getenv("PERL_DESTRUCT_LEVEL"))) {
 320             int i = atoi(s);
 321             if (destruct_level < i)
 322                 destruct_level = i;
 323         }
 324     }
 325 #endif
 326
 327
 328     if(PL_exit_flags & PERL_EXIT_DESTRUCT_END) {
 329         dJMPENV;
 330         int x = 0;
 331
 332         JMPENV_PUSH(x);
 333         if (PL_endav && !PL_minus_c)
 334             call_list(PL_scopestack_ix, PL_endav);
 335         JMPENV_POP;
 336     }
 337     LEAVE;
 338     FREETMPS;
 339
 340     /* Need to flush since END blocks can produce output */
 341     my_fflush_all();
 342
 343     if (CALL_FPTR(PL_threadhook)(aTHX)) {
 344         /* Threads hook has vetoed further cleanup */
 345         return STATUS_NATIVE_EXPORT;
 346     }
 347
 348     /* We must account for everything.  */
 349
 350     /* Destroy the main CV and syntax tree */
 351     if (PL_main_root) {
 352         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     while (--PL_origargc >= 0) {
 493         Safefree(PL_origargv[PL_origargc]);
 494     }
 495     Safefree(PL_origargv);
 496
 497     /* magical thingies */
 498
 499     SvREFCNT_dec(PL_ofs_sv);    /* $, */
 500     PL_ofs_sv = Nullsv;
 501
 502     SvREFCNT_dec(PL_ors_sv);    /* $\ */
 503     PL_ors_sv = Nullsv;
 504
 505     SvREFCNT_dec(PL_rs);        /* $/ */
 506     PL_rs = Nullsv;
 507
 508     PL_multiline = 0;           /* $* */
 509     Safefree(PL_osname);        /* $^O */
 510     PL_osname = Nullch;
 511
 512     SvREFCNT_dec(PL_statname);
 513     PL_statname = Nullsv;
 514     PL_statgv = Nullgv;
 515
 516     /* defgv, aka *_ should be taken care of elsewhere */
 517
 518     /* clean up after study() */
 519     SvREFCNT_dec(PL_lastscream);
 520     PL_lastscream = Nullsv;
 521     Safefree(PL_screamfirst);
 522     PL_screamfirst = 0;
 523     Safefree(PL_screamnext);
 524     PL_screamnext  = 0;
 525
 526     /* float buffer */
 527     Safefree(PL_efloatbuf);
 528     PL_efloatbuf = Nullch;
 529     PL_efloatsize = 0;
 530
 531     /* startup and shutdown function lists */
 532     SvREFCNT_dec(PL_beginav);
 533     SvREFCNT_dec(PL_beginav_save);
 534     SvREFCNT_dec(PL_endav);
 535     SvREFCNT_dec(PL_checkav);
 536     SvREFCNT_dec(PL_checkav_save);
 537     SvREFCNT_dec(PL_initav);
 538     PL_beginav = Nullav;
 539     PL_beginav_save = Nullav;
 540     PL_endav = Nullav;
 541     PL_checkav = Nullav;
 542     PL_checkav_save = Nullav;
 543     PL_initav = Nullav;
 544
 545     /* shortcuts just get cleared */
 546     PL_envgv = Nullgv;
 547     PL_incgv = Nullgv;
 548     PL_hintgv = Nullgv;
 549     PL_errgv = Nullgv;
 550     PL_argvgv = Nullgv;
 551     PL_argvoutgv = Nullgv;
 552     PL_stdingv = Nullgv;
 553     PL_stderrgv = Nullgv;
 554     PL_last_in_gv = Nullgv;
 555     PL_replgv = Nullgv;
 556     PL_debstash = Nullhv;
 557
 558     /* reset so print() ends up where we expect */
 559     setdefout(Nullgv);
 560
 561     SvREFCNT_dec(PL_argvout_stack);
 562     PL_argvout_stack = Nullav;
 563
 564     SvREFCNT_dec(PL_modglobal);
 565     PL_modglobal = Nullhv;
 566     SvREFCNT_dec(PL_preambleav);
 567     PL_preambleav = Nullav;
 568     SvREFCNT_dec(PL_subname);
 569     PL_subname = Nullsv;
 570     SvREFCNT_dec(PL_linestr);
 571     PL_linestr = Nullsv;
 572     SvREFCNT_dec(PL_pidstatus);
 573     PL_pidstatus = Nullhv;
 574     SvREFCNT_dec(PL_toptarget);
 575     PL_toptarget = Nullsv;
 576     SvREFCNT_dec(PL_bodytarget);
 577     PL_bodytarget = Nullsv;
 578     PL_formtarget = Nullsv;
 579
 580     /* free locale stuff */
 581 #ifdef USE_LOCALE_COLLATE
 582     Safefree(PL_collation_name);
 583     PL_collation_name = Nullch;
 584 #endif
 585
 586 #ifdef USE_LOCALE_NUMERIC
 587     Safefree(PL_numeric_name);
 588     PL_numeric_name = Nullch;
 589     SvREFCNT_dec(PL_numeric_radix_sv);
 590 #endif
 591
 592     /* clear utf8 character classes */
 593     SvREFCNT_dec(PL_utf8_alnum);
 594     SvREFCNT_dec(PL_utf8_alnumc);
 595     SvREFCNT_dec(PL_utf8_ascii);
 596     SvREFCNT_dec(PL_utf8_alpha);
 597     SvREFCNT_dec(PL_utf8_space);
 598     SvREFCNT_dec(PL_utf8_cntrl);
 599     SvREFCNT_dec(PL_utf8_graph);
 600     SvREFCNT_dec(PL_utf8_digit);
 601     SvREFCNT_dec(PL_utf8_upper);
 602     SvREFCNT_dec(PL_utf8_lower);
 603     SvREFCNT_dec(PL_utf8_print);
 604     SvREFCNT_dec(PL_utf8_punct);
 605     SvREFCNT_dec(PL_utf8_xdigit);
 606     SvREFCNT_dec(PL_utf8_mark);
 607     SvREFCNT_dec(PL_utf8_toupper);
 608     SvREFCNT_dec(PL_utf8_totitle);
 609     SvREFCNT_dec(PL_utf8_tolower);
 610     SvREFCNT_dec(PL_utf8_tofold);
 611     SvREFCNT_dec(PL_utf8_idstart);
 612     SvREFCNT_dec(PL_utf8_idcont);
 613     PL_utf8_alnum       = Nullsv;
 614     PL_utf8_alnumc      = Nullsv;
 615     PL_utf8_ascii       = Nullsv;
 616     PL_utf8_alpha       = Nullsv;
 617     PL_utf8_space       = Nullsv;
 618     PL_utf8_cntrl       = Nullsv;
 619     PL_utf8_graph       = Nullsv;
 620     PL_utf8_digit       = Nullsv;
 621     PL_utf8_upper       = Nullsv;
 622     PL_utf8_lower       = Nullsv;
 623     PL_utf8_print       = Nullsv;
 624     PL_utf8_punct       = Nullsv;
 625     PL_utf8_xdigit      = Nullsv;
 626     PL_utf8_mark        = Nullsv;
 627     PL_utf8_toupper     = Nullsv;
 628     PL_utf8_totitle     = Nullsv;
 629     PL_utf8_tolower     = Nullsv;
 630     PL_utf8_tofold      = Nullsv;
 631     PL_utf8_idstart     = Nullsv;
 632     PL_utf8_idcont      = Nullsv;
 633
 634     if (!specialWARN(PL_compiling.cop_warnings))
 635         SvREFCNT_dec(PL_compiling.cop_warnings);
 636     PL_compiling.cop_warnings = Nullsv;
 637     if (!specialCopIO(PL_compiling.cop_io))
 638         SvREFCNT_dec(PL_compiling.cop_io);
 639     PL_compiling.cop_io = Nullsv;
 640     CopFILE_free(&PL_compiling);
 641     CopSTASH_free(&PL_compiling);
 642
 643     /* Prepare to destruct main symbol table.  */
 644
 645     hv = PL_defstash;
 646     PL_defstash = 0;
 647     SvREFCNT_dec(hv);
 648     SvREFCNT_dec(PL_curstname);
 649     PL_curstname = Nullsv;
 650
 651     /* clear queued errors */
 652     SvREFCNT_dec(PL_errors);
 653     PL_errors = Nullsv;
 654
 655     FREETMPS;
 656     if (destruct_level >= 2 && ckWARN_d(WARN_INTERNAL)) {
 657         if (PL_scopestack_ix != 0)
 658             Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
 659                  "Unbalanced scopes: %ld more ENTERs than LEAVEs\n",
 660                  (long)PL_scopestack_ix);
 661         if (PL_savestack_ix != 0)
 662             Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
 663                  "Unbalanced saves: %ld more saves than restores\n",
 664                  (long)PL_savestack_ix);
 665         if (PL_tmps_floor != -1)
 666             Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Unbalanced tmps: %ld more allocs than frees\n",
 667                  (long)PL_tmps_floor + 1);
 668         if (cxstack_ix != -1)
 669             Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Unbalanced context: %ld more PUSHes than POPs\n",
 670                  (long)cxstack_ix + 1);
 671     }
 672
 673     /* Now absolutely destruct everything, somehow or other, loops or no. */
 674     SvFLAGS(PL_fdpid) |= SVTYPEMASK;            /* don't clean out pid table now */
 675     SvFLAGS(PL_strtab) |= SVTYPEMASK;           /* don't clean out strtab now */
 676
 677     /* the 2 is for PL_fdpid and PL_strtab */
 678     while (PL_sv_count > 2 && sv_clean_all())
 679         ;
 680
 681     SvFLAGS(PL_fdpid) &= ~SVTYPEMASK;
 682     SvFLAGS(PL_fdpid) |= SVt_PVAV;
 683     SvFLAGS(PL_strtab) &= ~SVTYPEMASK;
 684     SvFLAGS(PL_strtab) |= SVt_PVHV;
 685
 686     AvREAL_off(PL_fdpid);               /* no surviving entries */
 687     SvREFCNT_dec(PL_fdpid);             /* needed in io_close() */
 688     PL_fdpid = Nullav;
 689
 690 #ifdef HAVE_INTERP_INTERN
 691     sys_intern_clear();
 692 #endif
 693
 694     /* Destruct the global string table. */
 695     {
 696         /* Yell and reset the HeVAL() slots that are still holding refcounts,
 697          * so that sv_free() won't fail on them.
 698          */
 699         I32 riter;
 700         I32 max;
 701         HE *hent;
 702         HE **array;
 703
 704         riter = 0;
 705         max = HvMAX(PL_strtab);
 706         array = HvARRAY(PL_strtab);
 707         hent = array[0];
 708         for (;;) {
 709             if (hent && ckWARN_d(WARN_INTERNAL)) {
 710                 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
 711                      "Unbalanced string table refcount: (%d) for \"%s\"",
 712                      HeVAL(hent) - Nullsv, HeKEY(hent));
 713                 HeVAL(hent) = Nullsv;
 714                 hent = HeNEXT(hent);
 715             }
 716             if (!hent) {
 717                 if (++riter > max)
 718                     break;
 719                 hent = array[riter];
 720             }
 721         }
 722     }
 723     SvREFCNT_dec(PL_strtab);
 724
 725 #ifdef USE_ITHREADS
 726     /* free the pointer table used for cloning */
 727     ptr_table_free(PL_ptr_table);
 728 #endif
 729
 730     /* free special SVs */
 731
 732     SvREFCNT(&PL_sv_yes) = 0;
 733     sv_clear(&PL_sv_yes);
 734     SvANY(&PL_sv_yes) = NULL;
 735     SvFLAGS(&PL_sv_yes) = 0;
 736
 737     SvREFCNT(&PL_sv_no) = 0;
 738     sv_clear(&PL_sv_no);
 739     SvANY(&PL_sv_no) = NULL;
 740     SvFLAGS(&PL_sv_no) = 0;
 741
 742     {
 743         int i;
 744         for (i=0; i<=2; i++) {
 745             SvREFCNT(PERL_DEBUG_PAD(i)) = 0;
 746             sv_clear(PERL_DEBUG_PAD(i));
 747             SvANY(PERL_DEBUG_PAD(i)) = NULL;
 748             SvFLAGS(PERL_DEBUG_PAD(i)) = 0;
 749         }
 750     }
 751
 752     if (PL_sv_count != 0 && ckWARN_d(WARN_INTERNAL))
 753         Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Scalars leaked: %ld\n", (long)PL_sv_count);
 754
 755 #if defined(PERLIO_LAYERS)
 756     /* No more IO - including error messages ! */
 757     PerlIO_cleanup(aTHX);
 758 #endif
 759
 760     /* sv_undef needs to stay immortal until after PerlIO_cleanup
 761        as currently layers use it rather than Nullsv as a marker
 762        for no arg - and will try and SvREFCNT_dec it.
 763      */
 764     SvREFCNT(&PL_sv_undef) = 0;
 765     SvREADONLY_off(&PL_sv_undef);
 766
 767     Safefree(PL_origfilename);
 768     Safefree(PL_reg_start_tmp);
 769     if (PL_reg_curpm)
 770         Safefree(PL_reg_curpm);
 771     Safefree(PL_reg_poscache);
 772     Safefree(HeKEY_hek(&PL_hv_fetch_ent_mh));
 773     Safefree(PL_op_mask);
 774     Safefree(PL_psig_ptr);
 775     Safefree(PL_psig_name);
 776     Safefree(PL_bitcount);
 777     Safefree(PL_psig_pend);
 778     nuke_stacks();
 779     PL_hints = 0;               /* Reset hints. Should hints be per-interpreter ? */
 780
 781     DEBUG_P(debprofdump());
 782
 783 #ifdef USE_REENTRANT_API
 784     Perl_reentrant_free(aTHX);
 785 #endif
 786
 787     sv_free_arenas();
 788
 789     /* As the absolutely last thing, free the non-arena SV for mess() */
 790
 791     if (PL_mess_sv) {
 792         /* it could have accumulated taint magic */
 793         if (SvTYPE(PL_mess_sv) >= SVt_PVMG) {
 794             MAGIC* mg;
 795             MAGIC* moremagic;
 796             for (mg = SvMAGIC(PL_mess_sv); mg; mg = moremagic) {
 797                 moremagic = mg->mg_moremagic;
 798                 if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global
 799                                                 && mg->mg_len >= 0)
 800                     Safefree(mg->mg_ptr);
 801                 Safefree(mg);
 802             }
 803         }
 804         /* we know that type >= SVt_PV */
 805         (void)SvOOK_off(PL_mess_sv);
 806         Safefree(SvPVX(PL_mess_sv));
 807         Safefree(SvANY(PL_mess_sv));
 808         Safefree(PL_mess_sv);
 809         PL_mess_sv = Nullsv;
 810     }
 811     return STATUS_NATIVE_EXPORT;
 812 }
 813
 814 /*
 815 =for apidoc perl_free
 816
 817 Releases a Perl interpreter.  See L<perlembed>.
 818
 819 =cut
 820 */
 821
 822 void
 823 perl_free(pTHXx)
 824 {
 825 #if defined(WIN32) || defined(NETWARE)
 826 #  if defined(PERL_IMPLICIT_SYS)
 827 #    ifdef NETWARE
 828     void *host = nw_internal_host;
 829 #    else
 830     void *host = w32_internal_host;
 831 #    endif
 832     PerlMem_free(aTHXx);
 833 #    ifdef NETWARE
 834     nw_delete_internal_host(host);
 835 #    else
 836     win32_delete_internal_host(host);
 837 #    endif
 838 #  else
 839     PerlMem_free(aTHXx);
 840 #  endif
 841 #else
 842     PerlMem_free(aTHXx);
 843 #endif
 844 }
 845
 846 void
 847 Perl_call_atexit(pTHX_ ATEXIT_t fn, void *ptr)
 848 {
 849     Renew(PL_exitlist, PL_exitlistlen+1, PerlExitListEntry);
 850     PL_exitlist[PL_exitlistlen].fn = fn;
 851     PL_exitlist[PL_exitlistlen].ptr = ptr;
 852     ++PL_exitlistlen;
 853 }
 854
 855 /*
 856 =for apidoc perl_parse
 857
 858 Tells a Perl interpreter to parse a Perl script.  See L<perlembed>.
 859
 860 =cut
 861 */
 862
 863 int
 864 perl_parse(pTHXx_ XSINIT_t xsinit, int argc, char **argv, char **env)
 865 {
 866     I32 oldscope;
 867     int ret;
 868     dJMPENV;
 869 #ifdef USE_5005THREADS
 870     dTHX;
 871 #endif
 872
 873 #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
 874 #ifdef IAMSUID
 875 #undef IAMSUID
 876     Perl_croak(aTHX_ "suidperl is no longer needed since the kernel can now execute\n\
 877 setuid perl scripts securely.\n");
 878 #endif
 879 #endif
 880
 881     PL_origargc = argc;
 882     {
 883         /* we copy rather than point to argv
 884          * since perl_clone will copy and perl_destruct
 885          * has no way of knowing if we've made a copy or
 886          * just point to argv
 887          */
 888         int i = PL_origargc;
 889         New(0, PL_origargv, i+1, char*);
 890         PL_origargv[i] = '\0';
 891         while (i-- > 0) {
 892             PL_origargv[i] = savepv(argv[i]);
 893         }
 894     }
 895
 896
 897
 898     if (PL_do_undump) {
 899
 900         /* Come here if running an undumped a.out. */
 901
 902         PL_origfilename = savepv(argv[0]);
 903         PL_do_undump = FALSE;
 904         cxstack_ix = -1;                /* start label stack again */
 905         init_ids();
 906         init_postdump_symbols(argc,argv,env);
 907         return 0;
 908     }
 909
 910     if (PL_main_root) {
 911         op_free(PL_main_root);
 912         PL_main_root = Nullop;
 913     }
 914     PL_main_start = Nullop;
 915     SvREFCNT_dec(PL_main_cv);
 916     PL_main_cv = Nullcv;
 917
 918     time(&PL_basetime);
 919     oldscope = PL_scopestack_ix;
 920     PL_dowarn = G_WARN_OFF;
 921
 922 #ifdef PERL_FLEXIBLE_EXCEPTIONS
 923     CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_vparse_body), env, xsinit);
 924 #else
 925     JMPENV_PUSH(ret);
 926 #endif
 927     switch (ret) {
 928     case 0:
 929 #ifndef PERL_FLEXIBLE_EXCEPTIONS
 930         parse_body(env,xsinit);
 931 #endif
 932         if (PL_checkav)
 933             call_list(oldscope, PL_checkav);
 934         ret = 0;
 935         break;
 936     case 1:
 937         STATUS_ALL_FAILURE;
 938         /* FALL THROUGH */
 939     case 2:
 940         /* my_exit() was called */
 941         while (PL_scopestack_ix > oldscope)
 942             LEAVE;
 943         FREETMPS;
 944         PL_curstash = PL_defstash;
 945         if (PL_checkav)
 946             call_list(oldscope, PL_checkav);
 947         ret = STATUS_NATIVE_EXPORT;
 948         break;
 949     case 3:
 950         PerlIO_printf(Perl_error_log, "panic: top_env\n");
 951         ret = 1;
 952         break;
 953     }
 954     JMPENV_POP;
 955     return ret;
 956 }
 957
 958 #ifdef PERL_FLEXIBLE_EXCEPTIONS
 959 STATIC void *
 960 S_vparse_body(pTHX_ va_list args)
 961 {
 962     char **env = va_arg(args, char**);
 963     XSINIT_t xsinit = va_arg(args, XSINIT_t);
 964
 965     return parse_body(env, xsinit);
 966 }
 967 #endif
 968
 969 STATIC void *
 970 S_parse_body(pTHX_ char **env, XSINIT_t xsinit)
 971 {
 972     int argc = PL_origargc;
 973     char **argv = PL_origargv;
 974     char *scriptname = NULL;
 975     int fdscript = -1;
 976     VOL bool dosearch = FALSE;
 977     char *validarg = "";
 978     register SV *sv;
 979     register char *s;
 980     char *cddir = Nullch;
 981
 982     sv_setpvn(PL_linestr,"",0);
 983     sv = newSVpvn("",0);                /* first used for -I flags */
 984     SAVEFREESV(sv);
 985     init_main_stash();
 986
 987     for (argc--,argv++; argc > 0; argc--,argv++) {
 988         if (argv[0][0] != '-' || !argv[0][1])
 989             break;
 990 #ifdef DOSUID
 991     if (*validarg)
 992         validarg = " PHOOEY ";
 993     else
 994         validarg = argv[0];
 995 #endif
 996         s = argv[0]+1;
 997       reswitch:
 998         switch (*s) {
 999         case 'C':
1000 #ifdef  WIN32
1001             win32_argv2utf8(argc-1, argv+1);
1002             /* FALL THROUGH */
1003 #endif
1004 #ifndef PERL_STRICT_CR
1005         case '\r':
1006 #endif
1007         case ' ':
1008         case '0':
1009         case 'F':
1010         case 'a':
1011         case 'c':
1012         case 'd':
1013         case 'D':
1014         case 'h':
1015         case 'i':
1016         case 'l':
1017         case 'M':
1018         case 'm':
1019         case 'n':
1020         case 'p':
1021         case 's':
1022         case 'u':
1023         case 'U':
1024         case 'v':
1025         case 'W':
1026         case 'X':
1027         case 'w':
1028             if ((s = moreswitches(s)))
1029                 goto reswitch;
1030             break;
1031
1032         case 't':
1033             if( !PL_tainting ) {
1034                  PL_taint_warn = TRUE;
1035                  PL_tainting = TRUE;
1036             }
1037             s++;
1038             goto reswitch;
1039         case 'T':
1040             PL_tainting = TRUE;
1041             PL_taint_warn = FALSE;
1042             s++;
1043             goto reswitch;
1044
1045         case 'e':
1046 #ifdef MACOS_TRADITIONAL
1047             /* ignore -e for Dev:Pseudo argument */
1048             if (argv[1] && !strcmp(argv[1], "Dev:Pseudo"))
1049                 break;
1050 #endif
1051             if (PL_euid != PL_uid || PL_egid != PL_gid)
1052                 Perl_croak(aTHX_ "No -e allowed in setuid scripts");
1053             if (!PL_e_script) {
1054                 PL_e_script = newSVpvn("",0);
1055                 filter_add(read_e_script, NULL);
1056             }
1057             if (*++s)
1058                 sv_catpv(PL_e_script, s);
1059             else if (argv[1]) {
1060                 sv_catpv(PL_e_script, argv[1]);
1061                 argc--,argv++;
1062             }
1063             else
1064                 Perl_croak(aTHX_ "No code specified for -e");
1065             sv_catpv(PL_e_script, "\n");
1066             break;
1067
1068         case 'I':       /* -I handled both here and in moreswitches() */
1069             forbid_setid("-I");
1070             if (!*++s && (s=argv[1]) != Nullch) {
1071                 argc--,argv++;
1072             }
1073             if (s && *s) {
1074                 char *p;
1075                 STRLEN len = strlen(s);
1076                 p = savepvn(s, len);
1077                 incpush(p, TRUE, TRUE, FALSE);
1078                 sv_catpvn(sv, "-I", 2);
1079                 sv_catpvn(sv, p, len);
1080                 sv_catpvn(sv, " ", 1);
1081                 Safefree(p);
1082             }
1083             else
1084                 Perl_croak(aTHX_ "No directory specified for -I");
1085             break;
1086         case 'P':
1087             forbid_setid("-P");
1088             PL_preprocess = TRUE;
1089             s++;
1090             goto reswitch;
1091         case 'S':
1092             forbid_setid("-S");
1093             dosearch = TRUE;
1094             s++;
1095             goto reswitch;
1096         case 'V':
1097             if (!PL_preambleav)
1098                 PL_preambleav = newAV();
1099             av_push(PL_preambleav, newSVpv("use Config qw(myconfig config_vars)",0));
1100             if (*++s != ':')  {
1101                 PL_Sv = newSVpv("print myconfig();",0);
1102 #ifdef VMS
1103                 sv_catpv(PL_Sv,"print \"\\nCharacteristics of this PERLSHR image: \\n\",");
1104 #else
1105                 sv_catpv(PL_Sv,"print \"\\nCharacteristics of this binary (from libperl): \\n\",");
1106 #endif
1107                 sv_catpv(PL_Sv,"\"  Compile-time options:");
1108 #  ifdef DEBUGGING
1109                 sv_catpv(PL_Sv," DEBUGGING");
1110 #  endif
1111 #  ifdef MULTIPLICITY
1112                 sv_catpv(PL_Sv," MULTIPLICITY");
1113 #  endif
1114 #  ifdef USE_5005THREADS
1115                 sv_catpv(PL_Sv," USE_5005THREADS");
1116 #  endif
1117 #  ifdef USE_ITHREADS
1118                 sv_catpv(PL_Sv," USE_ITHREADS");
1119 #  endif
1120 #  ifdef USE_64_BIT_INT
1121                 sv_catpv(PL_Sv," USE_64_BIT_INT");
1122 #  endif
1123 #  ifdef USE_64_BIT_ALL
1124                 sv_catpv(PL_Sv," USE_64_BIT_ALL");
1125 #  endif
1126 #  ifdef USE_LONG_DOUBLE
1127                 sv_catpv(PL_Sv," USE_LONG_DOUBLE");
1128 #  endif
1129 #  ifdef USE_LARGE_FILES
1130                 sv_catpv(PL_Sv," USE_LARGE_FILES");
1131 #  endif
1132 #  ifdef USE_SOCKS
1133                 sv_catpv(PL_Sv," USE_SOCKS");
1134 #  endif
1135 #  ifdef PERL_IMPLICIT_CONTEXT
1136                 sv_catpv(PL_Sv," PERL_IMPLICIT_CONTEXT");
1137 #  endif
1138 #  ifdef PERL_IMPLICIT_SYS
1139                 sv_catpv(PL_Sv," PERL_IMPLICIT_SYS");
1140 #  endif
1141                 sv_catpv(PL_Sv,"\\n\",");
1142
1143 #if defined(LOCAL_PATCH_COUNT)
1144                 if (LOCAL_PATCH_COUNT > 0) {
1145                     int i;
1146                     sv_catpv(PL_Sv,"\"  Locally applied patches:\\n\",");
1147                     for (i = 1; i <= LOCAL_PATCH_COUNT; i++) {
1148                         if (PL_localpatches[i])
1149                             Perl_sv_catpvf(aTHX_ PL_Sv,"q\"  \t%s\n\",",PL_localpatches[i]);
1150                     }
1151                 }
1152 #endif
1153                 Perl_sv_catpvf(aTHX_ PL_Sv,"\"  Built under %s\\n\"",OSNAME);
1154 #ifdef __DATE__
1155 #  ifdef __TIME__
1156                 Perl_sv_catpvf(aTHX_ PL_Sv,",\"  Compiled at %s %s\\n\"",__DATE__,__TIME__);
1157 #  else
1158                 Perl_sv_catpvf(aTHX_ PL_Sv,",\"  Compiled on %s\\n\"",__DATE__);
1159 #  endif
1160 #endif
1161                 sv_catpv(PL_Sv, "; \
1162 $\"=\"\\n    \"; \
1163 @env = map { \"$_=\\\"$ENV{$_}\\\"\" } sort grep {/^PERL/} keys %ENV; ");
1164 #ifdef __CYGWIN__
1165                 sv_catpv(PL_Sv,"\
1166 push @env, \"CYGWIN=\\\"$ENV{CYGWIN}\\\"\";");
1167 #endif
1168                 sv_catpv(PL_Sv, "\
1169 print \"  \\%ENV:\\n    @env\\n\" if @env; \
1170 print \"  \\@INC:\\n    @INC\\n\";");
1171             }
1172             else {
1173                 PL_Sv = newSVpv("config_vars(qw(",0);
1174                 sv_catpv(PL_Sv, ++s);
1175                 sv_catpv(PL_Sv, "))");
1176                 s += strlen(s);
1177             }
1178             av_push(PL_preambleav, PL_Sv);
1179             scriptname = BIT_BUCKET;    /* don't look for script or read stdin */
1180             goto reswitch;
1181         case 'x':
1182             PL_doextract = TRUE;
1183             s++;
1184             if (*s)
1185                 cddir = s;
1186             break;
1187         case 0:
1188             break;
1189         case '-':
1190             if (!*++s || isSPACE(*s)) {
1191                 argc--,argv++;
1192                 goto switch_end;
1193             }
1194             /* catch use of gnu style long options */
1195             if (strEQ(s, "version")) {
1196                 s = "v";
1197                 goto reswitch;
1198             }
1199             if (strEQ(s, "help")) {
1200                 s = "h";
1201                 goto reswitch;
1202             }
1203             s--;
1204             /* FALL THROUGH */
1205         default:
1206             Perl_croak(aTHX_ "Unrecognized switch: -%s  (-h will show valid options)",s);
1207         }
1208     }
1209   switch_end:
1210     sv_setsv(get_sv("/", TRUE), PL_rs);
1211
1212     if (
1213 #ifndef SECURE_INTERNAL_GETENV
1214         !PL_tainting &&
1215 #endif
1216         (s = PerlEnv_getenv("PERL5OPT")))
1217     {
1218         char *popt = s;
1219         while (isSPACE(*s))
1220             s++;
1221         if (*s == '-' && *(s+1) == 'T') {
1222             PL_tainting = TRUE;
1223             PL_taint_warn = FALSE;
1224         }
1225         else {
1226             char *popt_copy = Nullch;
1227             while (s && *s) {
1228                 char *d;
1229                 while (isSPACE(*s))
1230                     s++;
1231                 if (*s == '-') {
1232                     s++;
1233                     if (isSPACE(*s))
1234                         continue;
1235                 }
1236                 d = s;
1237                 if (!*s)
1238                     break;
1239                 if (!strchr("DIMUdmtw", *s))
1240                     Perl_croak(aTHX_ "Illegal switch in PERL5OPT: -%c", *s);
1241                 while (++s && *s) {
1242                     if (isSPACE(*s)) {
1243                         if (!popt_copy) {
1244                             popt_copy = SvPVX(sv_2mortal(newSVpv(popt,0)));
1245                             s = popt_copy + (s - popt);
1246                             d = popt_copy + (d - popt);
1247                         }
1248                         *s++ = '\0';
1249                         break;
1250                     }
1251                 }
1252                 if (*d == 't') {
1253                     if( !PL_tainting ) {
1254                         PL_taint_warn = TRUE;
1255                         PL_tainting = TRUE;
1256                     }
1257                 } else {
1258                     moreswitches(d);
1259                 }
1260             }
1261         }
1262     }
1263
1264     if (PL_taint_warn && PL_dowarn != G_WARN_ALL_OFF) {
1265        PL_compiling.cop_warnings = newSVpvn(WARN_TAINTstring, WARNsize);
1266     }
1267
1268     if (!scriptname)
1269         scriptname = argv[0];
1270     if (PL_e_script) {
1271         argc++,argv--;
1272         scriptname = BIT_BUCKET;        /* don't look for script or read stdin */
1273     }
1274     else if (scriptname == Nullch) {
1275 #ifdef MSDOS
1276         if ( PerlLIO_isatty(PerlIO_fileno(PerlIO_stdin())) )
1277             moreswitches("h");
1278 #endif
1279         scriptname = "-";
1280     }
1281
1282     init_perllib();
1283
1284     open_script(scriptname,dosearch,sv,&fdscript);
1285
1286     validate_suid(validarg, scriptname,fdscript);
1287
1288 #ifndef PERL_MICRO
1289 #if defined(SIGCHLD) || defined(SIGCLD)
1290     {
1291 #ifndef SIGCHLD
1292 #  define SIGCHLD SIGCLD
1293 #endif
1294         Sighandler_t sigstate = rsignal_state(SIGCHLD);
1295         if (sigstate == SIG_IGN) {
1296             if (ckWARN(WARN_SIGNAL))
1297                 Perl_warner(aTHX_ packWARN(WARN_SIGNAL),
1298                             "Can't ignore signal CHLD, forcing to default");
1299             (void)rsignal(SIGCHLD, (Sighandler_t)SIG_DFL);
1300         }
1301     }
1302 #endif
1303 #endif
1304
1305 #ifdef MACOS_TRADITIONAL
1306     if (PL_doextract || gMacPerl_AlwaysExtract) {
1307 #else
1308     if (PL_doextract) {
1309 #endif
1310         find_beginning();
1311         if (cddir && PerlDir_chdir(cddir) < 0)
1312             Perl_croak(aTHX_ "Can't chdir to %s",cddir);
1313
1314     }
1315
1316     PL_main_cv = PL_compcv = (CV*)NEWSV(1104,0);
1317     sv_upgrade((SV *)PL_compcv, SVt_PVCV);
1318     CvUNIQUE_on(PL_compcv);
1319
1320     CvPADLIST(PL_compcv) = pad_new(0);
1321 #ifdef USE_5005THREADS
1322     CvOWNER(PL_compcv) = 0;
1323     New(666, CvMUTEXP(PL_compcv), 1, perl_mutex);
1324     MUTEX_INIT(CvMUTEXP(PL_compcv));
1325 #endif /* USE_5005THREADS */
1326
1327     boot_core_PerlIO();
1328     boot_core_UNIVERSAL();
1329 #ifndef PERL_MICRO
1330     boot_core_xsutils();
1331 #endif
1332
1333     if (xsinit)
1334         (*xsinit)(aTHX);        /* in case linked C routines want magical variables */
1335 #ifndef PERL_MICRO
1336 #if defined(VMS) || defined(WIN32) || defined(DJGPP) || defined(__CYGWIN__) || defined(EPOC)
1337     init_os_extras();
1338 #endif
1339 #endif
1340
1341 #ifdef USE_SOCKS
1342 #   ifdef HAS_SOCKS5_INIT
1343     socks5_init(argv[0]);
1344 #   else
1345     SOCKSinit(argv[0]);
1346 #   endif
1347 #endif
1348
1349     init_predump_symbols();
1350     /* init_postdump_symbols not currently designed to be called */
1351     /* more than once (ENV isn't cleared first, for example)     */
1352     /* But running with -u leaves %ENV & @ARGV undefined!    XXX */
1353     if (!PL_do_undump)
1354         init_postdump_symbols(argc,argv,env);
1355
1356     /* PL_wantutf8 is conditionally turned on by
1357      * locale.c:Perl_init_i18nl10n() if the environment
1358      * look like the user wants to use UTF-8. */
1359     if (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_widesyscalls = TRUE;
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_widesyscalls)
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                 STRLEN n_a;
3910                 PL_curcop = &PL_compiling;
3911                 CopLINE_set(PL_curcop, oldline);
3912                 if (paramList == PL_beginav)
3913                     sv_catpv(atsv, "BEGIN failed--compilation aborted");
3914                 else
3915                     Perl_sv_catpvf(aTHX_ atsv,
3916                                    "%s failed--call queue aborted",
3917                                    paramList == PL_checkav ? "CHECK"
3918                                    : paramList == PL_initav ? "INIT"
3919                                    : "END");
3920                 while (PL_scopestack_ix > oldscope)
3921                     LEAVE;
3922                 JMPENV_POP;
3923                 Perl_croak(aTHX_ "%s", SvPVx(atsv, n_a));
3924             }
3925             break;
3926         case 1:
3927             STATUS_ALL_FAILURE;
3928             /* FALL THROUGH */
3929         case 2:
3930             /* my_exit() was called */
3931             while (PL_scopestack_ix > oldscope)
3932                 LEAVE;
3933             FREETMPS;
3934             PL_curstash = PL_defstash;
3935             PL_curcop = &PL_compiling;
3936             CopLINE_set(PL_curcop, oldline);
3937             JMPENV_POP;
3938             if (PL_statusvalue && !(PL_exit_flags & PERL_EXIT_EXPECTED)) {
3939                 if (paramList == PL_beginav)
3940                     Perl_croak(aTHX_ "BEGIN failed--compilation aborted");
3941                 else
3942                     Perl_croak(aTHX_ "%s failed--call queue aborted",
3943                                paramList == PL_checkav ? "CHECK"
3944                                : paramList == PL_initav ? "INIT"
3945                                : "END");
3946             }
3947             my_exit_jump();
3948             /* NOTREACHED */
3949         case 3:
3950             if (PL_restartop) {
3951                 PL_curcop = &PL_compiling;
3952                 CopLINE_set(PL_curcop, oldline);
3953                 JMPENV_JUMP(3);
3954             }
3955             PerlIO_printf(Perl_error_log, "panic: restartop\n");
3956             FREETMPS;
3957             break;
3958         }
3959         JMPENV_POP;
3960     }
3961 }
3962
3963 #ifdef PERL_FLEXIBLE_EXCEPTIONS
3964 STATIC void *
3965 S_vcall_list_body(pTHX_ va_list args)
3966 {
3967     CV *cv = va_arg(args, CV*);
3968     return call_list_body(cv);
3969 }
3970 #endif
3971
3972 STATIC void *
3973 S_call_list_body(pTHX_ CV *cv)
3974 {
3975     PUSHMARK(PL_stack_sp);
3976     call_sv((SV*)cv, G_EVAL|G_DISCARD);
3977     return NULL;
3978 }
3979
3980 void
3981 Perl_my_exit(pTHX_ U32 status)
3982 {
3983     DEBUG_S(PerlIO_printf(Perl_debug_log, "my_exit: thread %p, status %lu\n",
3984                           thr, (unsigned long) status));
3985     switch (status) {
3986     case 0:
3987         STATUS_ALL_SUCCESS;
3988         break;
3989     case 1:
3990         STATUS_ALL_FAILURE;
3991         break;
3992     default:
3993         STATUS_NATIVE_SET(status);
3994         break;
3995     }
3996     my_exit_jump();
3997 }
3998
3999 void
4000 Perl_my_failure_exit(pTHX)
4001 {
4002 #ifdef VMS
4003     if (vaxc$errno & 1) {
4004         if (STATUS_NATIVE & 1)          /* fortuitiously includes "-1" */
4005             STATUS_NATIVE_SET(44);
4006     }
4007     else {
4008         if (!vaxc$errno && errno)       /* unlikely */
4009             STATUS_NATIVE_SET(44);
4010         else
4011             STATUS_NATIVE_SET(vaxc$errno);
4012     }
4013 #else
4014     int exitstatus;
4015     if (errno & 255)
4016         STATUS_POSIX_SET(errno);
4017     else {
4018         exitstatus = STATUS_POSIX >> 8;
4019         if (exitstatus & 255)
4020             STATUS_POSIX_SET(exitstatus);
4021         else
4022             STATUS_POSIX_SET(255);
4023     }
4024 #endif
4025     my_exit_jump();
4026 }
4027
4028 STATIC void
4029 S_my_exit_jump(pTHX)
4030 {
4031     register PERL_CONTEXT *cx;
4032     I32 gimme;
4033     SV **newsp;
4034
4035     if (PL_e_script) {
4036         SvREFCNT_dec(PL_e_script);
4037         PL_e_script = Nullsv;
4038     }
4039
4040     POPSTACK_TO(PL_mainstack);
4041     if (cxstack_ix >= 0) {
4042         if (cxstack_ix > 0)
4043             dounwind(0);
4044         POPBLOCK(cx,PL_curpm);
4045         LEAVE;
4046     }
4047
4048     JMPENV_JUMP(2);
4049 }
4050
4051 static I32
4052 read_e_script(pTHX_ int idx, SV *buf_sv, int maxlen)
4053 {
4054     char *p, *nl;
4055     p  = SvPVX(PL_e_script);
4056     nl = strchr(p, '\n');
4057     nl = (nl) ? nl+1 : SvEND(PL_e_script);
4058     if (nl-p == 0) {
4059         filter_del(read_e_script);
4060         return 0;
4061     }
4062     sv_catpvn(buf_sv, p, nl-p);
4063     sv_chop(PL_e_script, nl);
4064     return 1;
4065 }