perl.c

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