perl.c

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