perl.c

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