perl.c

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