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