perl.c

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