perl.c

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