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