perl.c

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