perl.c

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