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     if (PL_wantutf8) { /* Requires init_predump_symbols(). */
1482          IO* io;
1483          PerlIO* fp;
1484          SV* sv;
1485          if (PL_stdingv  && (io = GvIO(PL_stdingv))  && (fp = IoIFP(io)))
1486               PerlIO_binmode(aTHX_ fp, IoTYPE(io), 0, ":utf8");
1487          if (PL_defoutgv && (io = GvIO(PL_defoutgv)) && (fp = IoOFP(io)))
1488               PerlIO_binmode(aTHX_ fp, IoTYPE(io), 0, ":utf8");
1489          if (PL_stderrgv && (io = GvIO(PL_stderrgv)) && (fp = IoOFP(io)))
1490               PerlIO_binmode(aTHX_ fp, IoTYPE(io), 0, ":utf8");
1491          if ((sv = GvSV(gv_fetchpv("\017PEN", TRUE, SVt_PV)))) {
1492              sv_setpvn(sv, ":utf8\0:utf8", 11);
1493              SvSETMAGIC(sv);
1494          }
1495     }
1496
1497     init_lexer();
1498
1499     /* now parse the script */
1500
1501     SETERRNO(0,SS$_NORMAL);
1502     PL_error_count = 0;
1503 #ifdef MACOS_TRADITIONAL
1504     if (gMacPerl_SyntaxError = (yyparse() || PL_error_count)) {
1505         if (PL_minus_c)
1506             Perl_croak(aTHX_ "%s had compilation errors.\n", MacPerl_MPWFileName(PL_origfilename));
1507         else {
1508             Perl_croak(aTHX_ "Execution of %s aborted due to compilation errors.\n",
1509                        MacPerl_MPWFileName(PL_origfilename));
1510         }
1511     }
1512 #else
1513     if (yyparse() || PL_error_count) {
1514         if (PL_minus_c)
1515             Perl_croak(aTHX_ "%s had compilation errors.\n", PL_origfilename);
1516         else {
1517             Perl_croak(aTHX_ "Execution of %s aborted due to compilation errors.\n",
1518                        PL_origfilename);
1519         }
1520     }
1521 #endif
1522     CopLINE_set(PL_curcop, 0);
1523     PL_curstash = PL_defstash;
1524     PL_preprocess = FALSE;
1525     if (PL_e_script) {
1526         SvREFCNT_dec(PL_e_script);
1527         PL_e_script = Nullsv;
1528     }
1529
1530 /*
1531    Not sure that this is still the right place to do this now that we
1532    no longer use PL_nrs. HVDS 2001/09/09
1533 */
1534     sv_setsv(get_sv("/", TRUE), PL_rs);
1535
1536     if (PL_do_undump)
1537         my_unexec();
1538
1539     if (isWARN_ONCE) {
1540         SAVECOPFILE(PL_curcop);
1541         SAVECOPLINE(PL_curcop);
1542         gv_check(PL_defstash);
1543     }
1544
1545     LEAVE;
1546     FREETMPS;
1547
1548 #ifdef MYMALLOC
1549     if ((s=PerlEnv_getenv("PERL_DEBUG_MSTATS")) && atoi(s) >= 2)
1550         dump_mstats("after compilation:");
1551 #endif
1552
1553     ENTER;
1554     PL_restartop = 0;
1555     return NULL;
1556 }
1557
1558 /*
1559 =for apidoc perl_run
1560
1561 Tells a Perl interpreter to run.  See L<perlembed>.
1562
1563 =cut
1564 */
1565
1566 int
1567 perl_run(pTHXx)
1568 {
1569     I32 oldscope;
1570     int ret = 0;
1571     dJMPENV;
1572 #ifdef USE_5005THREADS
1573     dTHX;
1574 #endif
1575
1576     oldscope = PL_scopestack_ix;
1577 #ifdef VMS
1578     VMSISH_HUSHED = 0;
1579 #endif
1580
1581 #ifdef PERL_FLEXIBLE_EXCEPTIONS
1582  redo_body:
1583     CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_vrun_body), oldscope);
1584 #else
1585     JMPENV_PUSH(ret);
1586 #endif
1587     switch (ret) {
1588     case 1:
1589         cxstack_ix = -1;                /* start context stack again */
1590         goto redo_body;
1591     case 0:                             /* normal completion */
1592 #ifndef PERL_FLEXIBLE_EXCEPTIONS
1593  redo_body:
1594         run_body(oldscope);
1595 #endif
1596         /* FALL THROUGH */
1597     case 2:                             /* my_exit() */
1598         while (PL_scopestack_ix > oldscope)
1599             LEAVE;
1600         FREETMPS;
1601         PL_curstash = PL_defstash;
1602         if (!(PL_exit_flags & PERL_EXIT_DESTRUCT_END) &&
1603             PL_endav && !PL_minus_c)
1604             call_list(oldscope, PL_endav);
1605 #ifdef MYMALLOC
1606         if (PerlEnv_getenv("PERL_DEBUG_MSTATS"))
1607             dump_mstats("after execution:  ");
1608 #endif
1609         ret = STATUS_NATIVE_EXPORT;
1610         break;
1611     case 3:
1612         if (PL_restartop) {
1613             POPSTACK_TO(PL_mainstack);
1614             goto redo_body;
1615         }
1616         PerlIO_printf(Perl_error_log, "panic: restartop\n");
1617         FREETMPS;
1618         ret = 1;
1619         break;
1620     }
1621
1622     JMPENV_POP;
1623     return ret;
1624 }
1625
1626 #ifdef PERL_FLEXIBLE_EXCEPTIONS
1627 STATIC void *
1628 S_vrun_body(pTHX_ va_list args)
1629 {
1630     I32 oldscope = va_arg(args, I32);
1631
1632     return run_body(oldscope);
1633 }
1634 #endif
1635
1636
1637 STATIC void *
1638 S_run_body(pTHX_ I32 oldscope)
1639 {
1640     DEBUG_r(PerlIO_printf(Perl_debug_log, "%s $` $& $' support.\n",
1641                     PL_sawampersand ? "Enabling" : "Omitting"));
1642
1643     if (!PL_restartop) {
1644         DEBUG_x(dump_all());
1645         DEBUG(PerlIO_printf(Perl_debug_log, "\nEXECUTING...\n\n"));
1646         DEBUG_S(PerlIO_printf(Perl_debug_log, "main thread is 0x%"UVxf"\n",
1647                               PTR2UV(thr)));
1648
1649         if (PL_minus_c) {
1650 #ifdef MACOS_TRADITIONAL
1651             PerlIO_printf(Perl_error_log, "%s%s syntax OK\n",
1652                 (gMacPerl_ErrorFormat ? "# " : ""),
1653                 MacPerl_MPWFileName(PL_origfilename));
1654 #else
1655             PerlIO_printf(Perl_error_log, "%s syntax OK\n", PL_origfilename);
1656 #endif
1657             my_exit(0);
1658         }
1659         if (PERLDB_SINGLE && PL_DBsingle)
1660             sv_setiv(PL_DBsingle, 1);
1661         if (PL_initav)
1662             call_list(oldscope, PL_initav);
1663     }
1664
1665     /* do it */
1666
1667     if (PL_restartop) {
1668         PL_op = PL_restartop;
1669         PL_restartop = 0;
1670         CALLRUNOPS(aTHX);
1671     }
1672     else if (PL_main_start) {
1673         CvDEPTH(PL_main_cv) = 1;
1674         PL_op = PL_main_start;
1675         CALLRUNOPS(aTHX);
1676     }
1677
1678     my_exit(0);
1679     /* NOTREACHED */
1680     return NULL;
1681 }
1682
1683 /*
1684 =head1 SV Manipulation Functions
1685
1686 =for apidoc p||get_sv
1687
1688 Returns the SV of the specified Perl scalar.  If C<create> is set and the
1689 Perl variable does not exist then it will be created.  If C<create> is not
1690 set and the variable does not exist then NULL is returned.
1691
1692 =cut
1693 */
1694
1695 SV*
1696 Perl_get_sv(pTHX_ const char *name, I32 create)
1697 {
1698     GV *gv;
1699 #ifdef USE_5005THREADS
1700     if (name[1] == '\0' && !isALPHA(name[0])) {
1701         PADOFFSET tmp = find_threadsv(name);
1702         if (tmp != NOT_IN_PAD)
1703             return THREADSV(tmp);
1704     }
1705 #endif /* USE_5005THREADS */
1706     gv = gv_fetchpv(name, create, SVt_PV);
1707     if (gv)
1708         return GvSV(gv);
1709     return Nullsv;
1710 }
1711
1712 /*
1713 =head1 Array Manipulation Functions
1714
1715 =for apidoc p||get_av
1716
1717 Returns the AV of the specified Perl array.  If C<create> is set and the
1718 Perl variable does not exist then it will be created.  If C<create> is not
1719 set and the variable does not exist then NULL is returned.
1720
1721 =cut
1722 */
1723
1724 AV*
1725 Perl_get_av(pTHX_ const char *name, I32 create)
1726 {
1727     GV* gv = gv_fetchpv(name, create, SVt_PVAV);
1728     if (create)
1729         return GvAVn(gv);
1730     if (gv)
1731         return GvAV(gv);
1732     return Nullav;
1733 }
1734
1735 /*
1736 =head1 Hash Manipulation Functions
1737
1738 =for apidoc p||get_hv
1739
1740 Returns the HV of the specified Perl hash.  If C<create> is set and the
1741 Perl variable does not exist then it will be created.  If C<create> is not
1742 set and the variable does not exist then NULL is returned.
1743
1744 =cut
1745 */
1746
1747 HV*
1748 Perl_get_hv(pTHX_ const char *name, I32 create)
1749 {
1750     GV* gv = gv_fetchpv(name, create, SVt_PVHV);
1751     if (create)
1752         return GvHVn(gv);
1753     if (gv)
1754         return GvHV(gv);
1755     return Nullhv;
1756 }
1757
1758 /*
1759 =head1 CV Manipulation Functions
1760
1761 =for apidoc p||get_cv
1762
1763 Returns the CV of the specified Perl subroutine.  If C<create> is set and
1764 the Perl subroutine does not exist then it will be declared (which has the
1765 same effect as saying C<sub name;>).  If C<create> is not set and the
1766 subroutine does not exist then NULL is returned.
1767
1768 =cut
1769 */
1770
1771 CV*
1772 Perl_get_cv(pTHX_ const char *name, I32 create)
1773 {
1774     GV* gv = gv_fetchpv(name, create, SVt_PVCV);
1775     /* XXX unsafe for threads if eval_owner isn't held */
1776     /* XXX this is probably not what they think they're getting.
1777      * It has the same effect as "sub name;", i.e. just a forward
1778      * declaration! */
1779     if (create && !GvCVu(gv))
1780         return newSUB(start_subparse(FALSE, 0),
1781                       newSVOP(OP_CONST, 0, newSVpv(name,0)),
1782                       Nullop,
1783                       Nullop);
1784     if (gv)
1785         return GvCVu(gv);
1786     return Nullcv;
1787 }
1788
1789 /* Be sure to refetch the stack pointer after calling these routines. */
1790
1791 /*
1792
1793 =head1 Callback Functions
1794
1795 =for apidoc p||call_argv
1796
1797 Performs a callback to the specified Perl sub.  See L<perlcall>.
1798
1799 =cut
1800 */
1801
1802 I32
1803 Perl_call_argv(pTHX_ const char *sub_name, I32 flags, register char **argv)
1804
1805                         /* See G_* flags in cop.h */
1806                         /* null terminated arg list */
1807 {
1808     dSP;
1809
1810     PUSHMARK(SP);
1811     if (argv) {
1812         while (*argv) {
1813             XPUSHs(sv_2mortal(newSVpv(*argv,0)));
1814             argv++;
1815         }
1816         PUTBACK;
1817     }
1818     return call_pv(sub_name, flags);
1819 }
1820
1821 /*
1822 =for apidoc p||call_pv
1823
1824 Performs a callback to the specified Perl sub.  See L<perlcall>.
1825
1826 =cut
1827 */
1828
1829 I32
1830 Perl_call_pv(pTHX_ const char *sub_name, I32 flags)
1831                         /* name of the subroutine */
1832                         /* See G_* flags in cop.h */
1833 {
1834     return call_sv((SV*)get_cv(sub_name, TRUE), flags);
1835 }
1836
1837 /*
1838 =for apidoc p||call_method
1839
1840 Performs a callback to the specified Perl method.  The blessed object must
1841 be on the stack.  See L<perlcall>.
1842
1843 =cut
1844 */
1845
1846 I32
1847 Perl_call_method(pTHX_ const char *methname, I32 flags)
1848                         /* name of the subroutine */
1849                         /* See G_* flags in cop.h */
1850 {
1851     return call_sv(sv_2mortal(newSVpv(methname,0)), flags | G_METHOD);
1852 }
1853
1854 /* May be called with any of a CV, a GV, or an SV containing the name. */
1855 /*
1856 =for apidoc p||call_sv
1857
1858 Performs a callback to the Perl sub whose name is in the SV.  See
1859 L<perlcall>.
1860
1861 =cut
1862 */
1863
1864 I32
1865 Perl_call_sv(pTHX_ SV *sv, I32 flags)
1866                         /* See G_* flags in cop.h */
1867 {
1868     dSP;
1869     LOGOP myop;         /* fake syntax tree node */
1870     UNOP method_op;
1871     I32 oldmark;
1872     volatile I32 retval = 0;
1873     I32 oldscope;
1874     bool oldcatch = CATCH_GET;
1875     int ret;
1876     OP* oldop = PL_op;
1877     dJMPENV;
1878
1879     if (flags & G_DISCARD) {
1880         ENTER;
1881         SAVETMPS;
1882     }
1883
1884     Zero(&myop, 1, LOGOP);
1885     myop.op_next = Nullop;
1886     if (!(flags & G_NOARGS))
1887         myop.op_flags |= OPf_STACKED;
1888     myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
1889                       (flags & G_ARRAY) ? OPf_WANT_LIST :
1890                       OPf_WANT_SCALAR);
1891     SAVEOP();
1892     PL_op = (OP*)&myop;
1893
1894     EXTEND(PL_stack_sp, 1);
1895     *++PL_stack_sp = sv;
1896     oldmark = TOPMARK;
1897     oldscope = PL_scopestack_ix;
1898
1899     if (PERLDB_SUB && PL_curstash != PL_debstash
1900            /* Handle first BEGIN of -d. */
1901           && (PL_DBcv || (PL_DBcv = GvCV(PL_DBsub)))
1902            /* Try harder, since this may have been a sighandler, thus
1903             * curstash may be meaningless. */
1904           && (SvTYPE(sv) != SVt_PVCV || CvSTASH((CV*)sv) != PL_debstash)
1905           && !(flags & G_NODEBUG))
1906         PL_op->op_private |= OPpENTERSUB_DB;
1907
1908     if (flags & G_METHOD) {
1909         Zero(&method_op, 1, UNOP);
1910         method_op.op_next = PL_op;
1911         method_op.op_ppaddr = PL_ppaddr[OP_METHOD];
1912         myop.op_ppaddr = PL_ppaddr[OP_ENTERSUB];
1913         PL_op = (OP*)&method_op;
1914     }
1915
1916     if (!(flags & G_EVAL)) {
1917         CATCH_SET(TRUE);
1918         call_body((OP*)&myop, FALSE);
1919         retval = PL_stack_sp - (PL_stack_base + oldmark);
1920         CATCH_SET(oldcatch);
1921     }
1922     else {
1923         myop.op_other = (OP*)&myop;
1924         PL_markstack_ptr--;
1925         /* we're trying to emulate pp_entertry() here */
1926         {
1927             register PERL_CONTEXT *cx;
1928             I32 gimme = GIMME_V;
1929
1930             ENTER;
1931             SAVETMPS;
1932
1933             push_return(Nullop);
1934             PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), PL_stack_sp);
1935             PUSHEVAL(cx, 0, 0);
1936             PL_eval_root = PL_op;             /* Only needed so that goto works right. */
1937
1938             PL_in_eval = EVAL_INEVAL;
1939             if (flags & G_KEEPERR)
1940                 PL_in_eval |= EVAL_KEEPERR;
1941             else
1942                 sv_setpv(ERRSV,"");
1943         }
1944         PL_markstack_ptr++;
1945
1946 #ifdef PERL_FLEXIBLE_EXCEPTIONS
1947  redo_body:
1948         CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_vcall_body),
1949                     (OP*)&myop, FALSE);
1950 #else
1951         JMPENV_PUSH(ret);
1952 #endif
1953         switch (ret) {
1954         case 0:
1955 #ifndef PERL_FLEXIBLE_EXCEPTIONS
1956  redo_body:
1957             call_body((OP*)&myop, FALSE);
1958 #endif
1959             retval = PL_stack_sp - (PL_stack_base + oldmark);
1960             if (!(flags & G_KEEPERR))
1961                 sv_setpv(ERRSV,"");
1962             break;
1963         case 1:
1964             STATUS_ALL_FAILURE;
1965             /* FALL THROUGH */
1966         case 2:
1967             /* my_exit() was called */
1968             PL_curstash = PL_defstash;
1969             FREETMPS;
1970             JMPENV_POP;
1971             if (PL_statusvalue && !(PL_exit_flags & PERL_EXIT_EXPECTED))
1972                 Perl_croak(aTHX_ "Callback called exit");
1973             my_exit_jump();
1974             /* NOTREACHED */
1975         case 3:
1976             if (PL_restartop) {
1977                 PL_op = PL_restartop;
1978                 PL_restartop = 0;
1979                 goto redo_body;
1980             }
1981             PL_stack_sp = PL_stack_base + oldmark;
1982             if (flags & G_ARRAY)
1983                 retval = 0;
1984             else {
1985                 retval = 1;
1986                 *++PL_stack_sp = &PL_sv_undef;
1987             }
1988             break;
1989         }
1990
1991         if (PL_scopestack_ix > oldscope) {
1992             SV **newsp;
1993             PMOP *newpm;
1994             I32 gimme;
1995             register PERL_CONTEXT *cx;
1996             I32 optype;
1997
1998             POPBLOCK(cx,newpm);
1999             POPEVAL(cx);
2000             pop_return();
2001             PL_curpm = newpm;
2002             LEAVE;
2003         }
2004         JMPENV_POP;
2005     }
2006
2007     if (flags & G_DISCARD) {
2008         PL_stack_sp = PL_stack_base + oldmark;
2009         retval = 0;
2010         FREETMPS;
2011         LEAVE;
2012     }
2013     PL_op = oldop;
2014     return retval;
2015 }
2016
2017 #ifdef PERL_FLEXIBLE_EXCEPTIONS
2018 STATIC void *
2019 S_vcall_body(pTHX_ va_list args)
2020 {
2021     OP *myop = va_arg(args, OP*);
2022     int is_eval = va_arg(args, int);
2023
2024     call_body(myop, is_eval);
2025     return NULL;
2026 }
2027 #endif
2028
2029 STATIC void
2030 S_call_body(pTHX_ OP *myop, int is_eval)
2031 {
2032     if (PL_op == myop) {
2033         if (is_eval)
2034             PL_op = Perl_pp_entereval(aTHX);    /* this doesn't do a POPMARK */
2035         else
2036             PL_op = Perl_pp_entersub(aTHX);     /* this does */
2037     }
2038     if (PL_op)
2039         CALLRUNOPS(aTHX);
2040 }
2041
2042 /* Eval a string. The G_EVAL flag is always assumed. */
2043
2044 /*
2045 =for apidoc p||eval_sv
2046
2047 Tells Perl to C<eval> the string in the SV.
2048
2049 =cut
2050 */
2051
2052 I32
2053 Perl_eval_sv(pTHX_ SV *sv, I32 flags)
2054
2055                         /* See G_* flags in cop.h */
2056 {
2057     dSP;
2058     UNOP myop;          /* fake syntax tree node */
2059     volatile I32 oldmark = SP - PL_stack_base;
2060     volatile I32 retval = 0;
2061     I32 oldscope;
2062     int ret;
2063     OP* oldop = PL_op;
2064     dJMPENV;
2065
2066     if (flags & G_DISCARD) {
2067         ENTER;
2068         SAVETMPS;
2069     }
2070
2071     SAVEOP();
2072     PL_op = (OP*)&myop;
2073     Zero(PL_op, 1, UNOP);
2074     EXTEND(PL_stack_sp, 1);
2075     *++PL_stack_sp = sv;
2076     oldscope = PL_scopestack_ix;
2077
2078     if (!(flags & G_NOARGS))
2079         myop.op_flags = OPf_STACKED;
2080     myop.op_next = Nullop;
2081     myop.op_type = OP_ENTEREVAL;
2082     myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
2083                       (flags & G_ARRAY) ? OPf_WANT_LIST :
2084                       OPf_WANT_SCALAR);
2085     if (flags & G_KEEPERR)
2086         myop.op_flags |= OPf_SPECIAL;
2087
2088 #ifdef PERL_FLEXIBLE_EXCEPTIONS
2089  redo_body:
2090     CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_vcall_body),
2091                 (OP*)&myop, TRUE);
2092 #else
2093     JMPENV_PUSH(ret);
2094 #endif
2095     switch (ret) {
2096     case 0:
2097 #ifndef PERL_FLEXIBLE_EXCEPTIONS
2098  redo_body:
2099         call_body((OP*)&myop,TRUE);
2100 #endif
2101         retval = PL_stack_sp - (PL_stack_base + oldmark);
2102         if (!(flags & G_KEEPERR))
2103             sv_setpv(ERRSV,"");
2104         break;
2105     case 1:
2106         STATUS_ALL_FAILURE;
2107         /* FALL THROUGH */
2108     case 2:
2109         /* my_exit() was called */
2110         PL_curstash = PL_defstash;
2111         FREETMPS;
2112         JMPENV_POP;
2113         if (PL_statusvalue && !(PL_exit_flags & PERL_EXIT_EXPECTED))
2114             Perl_croak(aTHX_ "Callback called exit");
2115         my_exit_jump();
2116         /* NOTREACHED */
2117     case 3:
2118         if (PL_restartop) {
2119             PL_op = PL_restartop;
2120             PL_restartop = 0;
2121             goto redo_body;
2122         }
2123         PL_stack_sp = PL_stack_base + oldmark;
2124         if (flags & G_ARRAY)
2125             retval = 0;
2126         else {
2127             retval = 1;
2128             *++PL_stack_sp = &PL_sv_undef;
2129         }
2130         break;
2131     }
2132
2133     JMPENV_POP;
2134     if (flags & G_DISCARD) {
2135         PL_stack_sp = PL_stack_base + oldmark;
2136         retval = 0;
2137         FREETMPS;
2138         LEAVE;
2139     }
2140     PL_op = oldop;
2141     return retval;
2142 }
2143
2144 /*
2145 =for apidoc p||eval_pv
2146
2147 Tells Perl to C<eval> the given string and return an SV* result.
2148
2149 =cut
2150 */
2151
2152 SV*
2153 Perl_eval_pv(pTHX_ const char *p, I32 croak_on_error)
2154 {
2155     dSP;
2156     SV* sv = newSVpv(p, 0);
2157
2158     eval_sv(sv, G_SCALAR);
2159     SvREFCNT_dec(sv);
2160
2161     SPAGAIN;
2162     sv = POPs;
2163     PUTBACK;
2164
2165     if (croak_on_error && SvTRUE(ERRSV)) {
2166         STRLEN n_a;
2167         Perl_croak(aTHX_ SvPVx(ERRSV, n_a));
2168     }
2169
2170     return sv;
2171 }
2172
2173 /* Require a module. */
2174
2175 /*
2176 =head1 Embedding Functions
2177
2178 =for apidoc p||require_pv
2179
2180 Tells Perl to C<require> the file named by the string argument.  It is
2181 analogous to the Perl code C<eval "require '$file'">.  It's even
2182 implemented that way; consider using Perl_load_module instead.
2183
2184 =cut */
2185
2186 void
2187 Perl_require_pv(pTHX_ const char *pv)
2188 {
2189     SV* sv;
2190     dSP;
2191     PUSHSTACKi(PERLSI_REQUIRE);
2192     PUTBACK;
2193     sv = sv_newmortal();
2194     sv_setpv(sv, "require '");
2195     sv_catpv(sv, pv);
2196     sv_catpv(sv, "'");
2197     eval_sv(sv, G_DISCARD);
2198     SPAGAIN;
2199     POPSTACK;
2200 }
2201
2202 void
2203 Perl_magicname(pTHX_ char *sym, char *name, I32 namlen)
2204 {
2205     register GV *gv;
2206
2207     if ((gv = gv_fetchpv(sym,TRUE, SVt_PV)))
2208         sv_magic(GvSV(gv), (SV*)gv, PERL_MAGIC_sv, name, namlen);
2209 }
2210
2211 STATIC void
2212 S_usage(pTHX_ char *name)               /* XXX move this out into a module ? */
2213 {
2214     /* This message really ought to be max 23 lines.
2215      * Removed -h because the user already knows that option. Others? */
2216
2217     static char *usage_msg[] = {
2218 "-0[octal]       specify record separator (\\0, if no argument)",
2219 "-a              autosplit mode with -n or -p (splits $_ into @F)",
2220 "-C              enable native wide character system interfaces",
2221 "-c              check syntax only (runs BEGIN and CHECK blocks)",
2222 "-d[:debugger]   run program under debugger",
2223 "-D[number/list] set debugging flags (argument is a bit mask or alphabets)",
2224 "-e 'command'    one line of program (several -e's allowed, omit programfile)",
2225 "-F/pattern/     split() pattern for -a switch (//'s are optional)",
2226 "-i[extension]   edit <> files in place (makes backup if extension supplied)",
2227 "-Idirectory     specify @INC/#include directory (several -I's allowed)",
2228 "-l[octal]       enable line ending processing, specifies line terminator",
2229 "-[mM][-]module  execute `use/no module...' before executing program",
2230 "-n              assume 'while (<>) { ... }' loop around program",
2231 "-p              assume loop like -n but print line also, like sed",
2232 "-P              run program through C preprocessor before compilation",
2233 "-s              enable rudimentary parsing for switches after programfile",
2234 "-S              look for programfile using PATH environment variable",
2235 "-T              enable tainting checks",
2236 "-t              enable tainting warnings",
2237 "-u              dump core after parsing program",
2238 "-U              allow unsafe operations",
2239 "-v              print version, subversion (includes VERY IMPORTANT perl info)",
2240 "-V[:variable]   print configuration summary (or a single Config.pm variable)",
2241 "-w              enable many useful warnings (RECOMMENDED)",
2242 "-W              enable all warnings",
2243 "-X              disable all warnings",
2244 "-x[directory]   strip off text before #!perl line and perhaps cd to directory",
2245 "\n",
2246 NULL
2247 };
2248     char **p = usage_msg;
2249
2250     PerlIO_printf(PerlIO_stdout(),
2251                   "\nUsage: %s [switches] [--] [programfile] [arguments]",
2252                   name);
2253     while (*p)
2254         PerlIO_printf(PerlIO_stdout(), "\n  %s", *p++);
2255 }
2256
2257 /* This routine handles any switches that can be given during run */
2258
2259 char *
2260 Perl_moreswitches(pTHX_ char *s)
2261 {
2262     STRLEN numlen;
2263     U32 rschar;
2264
2265     switch (*s) {
2266     case '0':
2267     {
2268         I32 flags = 0;
2269         numlen = 4;
2270         rschar = (U32)grok_oct(s, &numlen, &flags, NULL);
2271         SvREFCNT_dec(PL_rs);
2272         if (rschar & ~((U8)~0))
2273             PL_rs = &PL_sv_undef;
2274         else if (!rschar && numlen >= 2)
2275             PL_rs = newSVpvn("", 0);
2276         else {
2277             char ch = (char)rschar;
2278             PL_rs = newSVpvn(&ch, 1);
2279         }
2280         return s + numlen;
2281     }
2282     case 'C':
2283         PL_widesyscalls = TRUE;
2284         s++;
2285         return s;
2286     case 'F':
2287         PL_minus_F = TRUE;
2288         PL_splitstr = ++s;
2289         while (*s && !isSPACE(*s)) ++s;
2290         *s = '\0';
2291         PL_splitstr = savepv(PL_splitstr);
2292         return s;
2293     case 'a':
2294         PL_minus_a = TRUE;
2295         s++;
2296         return s;
2297     case 'c':
2298         PL_minus_c = TRUE;
2299         s++;
2300         return s;
2301     case 'd':
2302         forbid_setid("-d");
2303         s++;
2304         /* The following permits -d:Mod to accepts arguments following an =
2305            in the fashion that -MSome::Mod does. */
2306         if (*s == ':' || *s == '=') {
2307             char *start;
2308             SV *sv;
2309             sv = newSVpv("use Devel::", 0);
2310             start = ++s;
2311             /* We now allow -d:Module=Foo,Bar */
2312             while(isALNUM(*s) || *s==':') ++s;
2313             if (*s != '=')
2314                 sv_catpv(sv, start);
2315             else {
2316                 sv_catpvn(sv, start, s-start);
2317                 sv_catpv(sv, " split(/,/,q{");
2318                 sv_catpv(sv, ++s);
2319                 sv_catpv(sv,    "})");
2320             }
2321             s += strlen(s);
2322             my_setenv("PERL5DB", SvPV(sv, PL_na));
2323         }
2324         if (!PL_perldb) {
2325             PL_perldb = PERLDB_ALL;
2326             init_debugger();
2327         }
2328         return s;
2329     case 'D':
2330     {
2331 #ifdef DEBUGGING
2332         forbid_setid("-D");
2333         if (isALPHA(s[1])) {
2334             /* if adding extra options, remember to update DEBUG_MASK */
2335             static char debopts[] = "psltocPmfrxuLHXDSTRJ";
2336             char *d;
2337
2338             for (s++; *s && (d = strchr(debopts,*s)); s++)
2339                 PL_debug |= 1 << (d - debopts);
2340         }
2341         else {
2342             PL_debug = atoi(s+1);
2343             for (s++; isDIGIT(*s); s++) ;
2344         }
2345 #ifdef EBCDIC
2346         if (DEBUG_p_TEST_ && ckWARN_d(WARN_DEBUGGING))
2347             Perl_warner(aTHX_ packWARN(WARN_DEBUGGING),
2348                     "-Dp not implemented on this platform\n");
2349 #endif
2350         PL_debug |= DEBUG_TOP_FLAG;
2351 #else /* !DEBUGGING */
2352         if (ckWARN_d(WARN_DEBUGGING))
2353             Perl_warner(aTHX_ packWARN(WARN_DEBUGGING),
2354                    "Recompile perl with -DDEBUGGING to use -D switch\n");
2355         for (s++; isALNUM(*s); s++) ;
2356 #endif
2357         /*SUPPRESS 530*/
2358         return s;
2359     }
2360     case 'h':
2361         usage(PL_origargv[0]);
2362         PerlProc_exit(0);
2363     case 'i':
2364         if (PL_inplace)
2365             Safefree(PL_inplace);
2366 #if defined(__CYGWIN__) /* do backup extension automagically */
2367         if (*(s+1) == '\0') {
2368         PL_inplace = savepv(".bak");
2369         return s+1;
2370         }
2371 #endif /* __CYGWIN__ */
2372         PL_inplace = savepv(s+1);
2373         /*SUPPRESS 530*/
2374         for (s = PL_inplace; *s && !isSPACE(*s); s++) ;
2375         if (*s) {
2376             *s++ = '\0';
2377             if (*s == '-')      /* Additional switches on #! line. */
2378                 s++;
2379         }
2380         return s;
2381     case 'I':   /* -I handled both here and in parse_body() */
2382         forbid_setid("-I");
2383         ++s;
2384         while (*s && isSPACE(*s))
2385             ++s;
2386         if (*s) {
2387             char *e, *p;
2388             p = s;
2389             /* ignore trailing spaces (possibly followed by other switches) */
2390             do {
2391                 for (e = p; *e && !isSPACE(*e); e++) ;
2392                 p = e;
2393                 while (isSPACE(*p))
2394                     p++;
2395             } while (*p && *p != '-');
2396             e = savepvn(s, e-s);
2397             incpush(e, TRUE, TRUE);
2398             Safefree(e);
2399             s = p;
2400             if (*s == '-')
2401                 s++;
2402         }
2403         else
2404             Perl_croak(aTHX_ "No directory specified for -I");
2405         return s;
2406     case 'l':
2407         PL_minus_l = TRUE;
2408         s++;
2409         if (PL_ors_sv) {
2410             SvREFCNT_dec(PL_ors_sv);
2411             PL_ors_sv = Nullsv;
2412         }
2413         if (isDIGIT(*s)) {
2414             I32 flags = 0;
2415             PL_ors_sv = newSVpvn("\n",1);
2416             numlen = 3 + (*s == '0');
2417             *SvPVX(PL_ors_sv) = (char)grok_oct(s, &numlen, &flags, NULL);
2418             s += numlen;
2419         }
2420         else {
2421             if (RsPARA(PL_rs)) {
2422                 PL_ors_sv = newSVpvn("\n\n",2);
2423             }
2424             else {
2425                 PL_ors_sv = newSVsv(PL_rs);
2426             }
2427         }
2428         return s;
2429     case 'M':
2430         forbid_setid("-M");     /* XXX ? */
2431         /* FALL THROUGH */
2432     case 'm':
2433         forbid_setid("-m");     /* XXX ? */
2434         if (*++s) {
2435             char *start;
2436             SV *sv;
2437             char *use = "use ";
2438             /* -M-foo == 'no foo'       */
2439             if (*s == '-') { use = "no "; ++s; }
2440             sv = newSVpv(use,0);
2441             start = s;
2442             /* We allow -M'Module qw(Foo Bar)'  */
2443             while(isALNUM(*s) || *s==':') ++s;
2444             if (*s != '=') {
2445                 sv_catpv(sv, start);
2446                 if (*(start-1) == 'm') {
2447                     if (*s != '\0')
2448                         Perl_croak(aTHX_ "Can't use '%c' after -mname", *s);
2449                     sv_catpv( sv, " ()");
2450                 }
2451             } else {
2452                 if (s == start)
2453                     Perl_croak(aTHX_ "Module name required with -%c option",
2454                                s[-1]);
2455                 sv_catpvn(sv, start, s-start);
2456                 sv_catpv(sv, " split(/,/,q{");
2457                 sv_catpv(sv, ++s);
2458                 sv_catpv(sv,    "})");
2459             }
2460             s += strlen(s);
2461             if (!PL_preambleav)
2462                 PL_preambleav = newAV();
2463             av_push(PL_preambleav, sv);
2464         }
2465         else
2466             Perl_croak(aTHX_ "No space allowed after -%c", *(s-1));
2467         return s;
2468     case 'n':
2469         PL_minus_n = TRUE;
2470         s++;
2471         return s;
2472     case 'p':
2473         PL_minus_p = TRUE;
2474         s++;
2475         return s;
2476     case 's':
2477         forbid_setid("-s");
2478         PL_doswitches = TRUE;
2479         s++;
2480         return s;
2481     case 't':
2482         if (!PL_tainting)
2483             Perl_croak(aTHX_ "Too late for \"-t\" option");
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 'u':
2492 #ifdef MACOS_TRADITIONAL
2493         Perl_croak(aTHX_ "Believe me, you don't want to use \"-u\" on a Macintosh");
2494 #endif
2495         PL_do_undump = TRUE;
2496         s++;
2497         return s;
2498     case 'U':
2499         PL_unsafe = TRUE;
2500         s++;
2501         return s;
2502     case 'v':
2503 #if !defined(DGUX)
2504         PerlIO_printf(PerlIO_stdout(),
2505                       Perl_form(aTHX_ "\nThis is perl, v%"VDf" built for %s",
2506                                 PL_patchlevel, ARCHNAME));
2507 #else /* DGUX */
2508 /* Adjust verbose output as in the perl that ships with the DG/UX OS from EMC */
2509         PerlIO_printf(PerlIO_stdout(),
2510                         Perl_form(aTHX_ "\nThis is perl, version %vd\n", PL_patchlevel));
2511         PerlIO_printf(PerlIO_stdout(),
2512                         Perl_form(aTHX_ "        built under %s at %s %s\n",
2513                                         OSNAME, __DATE__, __TIME__));
2514         PerlIO_printf(PerlIO_stdout(),
2515                         Perl_form(aTHX_ "        OS Specific Release: %s\n",
2516                                         OSVERS));
2517 #endif /* !DGUX */
2518
2519 #if defined(LOCAL_PATCH_COUNT)
2520         if (LOCAL_PATCH_COUNT > 0)
2521             PerlIO_printf(PerlIO_stdout(),
2522                           "\n(with %d registered patch%s, "
2523                           "see perl -V for more detail)",
2524                           (int)LOCAL_PATCH_COUNT,
2525                           (LOCAL_PATCH_COUNT!=1) ? "es" : "");
2526 #endif
2527
2528         PerlIO_printf(PerlIO_stdout(),
2529                       "\n\nCopyright 1987-2002, Larry Wall\n");
2530 #ifdef MACOS_TRADITIONAL
2531         PerlIO_printf(PerlIO_stdout(),
2532                       "\nMac OS port Copyright 1991-2002, Matthias Neeracher;\n"
2533                       "maintained by Chris Nandor\n");
2534 #endif
2535 #ifdef MSDOS
2536         PerlIO_printf(PerlIO_stdout(),
2537                       "\nMS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n");
2538 #endif
2539 #ifdef DJGPP
2540         PerlIO_printf(PerlIO_stdout(),
2541                       "djgpp v2 port (jpl5003c) by Hirofumi Watanabe, 1996\n"
2542                       "djgpp v2 port (perl5004+) by Laszlo Molnar, 1997-1999\n");
2543 #endif
2544 #ifdef OS2
2545         PerlIO_printf(PerlIO_stdout(),
2546                       "\n\nOS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n"
2547                       "Version 5 port Copyright (c) 1994-2002, Andreas Kaiser, Ilya Zakharevich\n");
2548 #endif
2549 #ifdef atarist
2550         PerlIO_printf(PerlIO_stdout(),
2551                       "atariST series port, ++jrb  bammi@cadence.com\n");
2552 #endif
2553 #ifdef __BEOS__
2554         PerlIO_printf(PerlIO_stdout(),
2555                       "BeOS port Copyright Tom Spindler, 1997-1999\n");
2556 #endif
2557 #ifdef MPE
2558         PerlIO_printf(PerlIO_stdout(),
2559                       "MPE/iX port Copyright by Mark Klein and Mark Bixby, 1996-2002\n");
2560 #endif
2561 #ifdef OEMVS
2562         PerlIO_printf(PerlIO_stdout(),
2563                       "MVS (OS390) port by Mortice Kern Systems, 1997-1999\n");
2564 #endif
2565 #ifdef __VOS__
2566         PerlIO_printf(PerlIO_stdout(),
2567                       "Stratus VOS port by Paul.Green@stratus.com, 1997-2002\n");
2568 #endif
2569 #ifdef __OPEN_VM
2570         PerlIO_printf(PerlIO_stdout(),
2571                       "VM/ESA port by Neale Ferguson, 1998-1999\n");
2572 #endif
2573 #ifdef POSIX_BC
2574         PerlIO_printf(PerlIO_stdout(),
2575                       "BS2000 (POSIX) port by Start Amadeus GmbH, 1998-1999\n");
2576 #endif
2577 #ifdef __MINT__
2578         PerlIO_printf(PerlIO_stdout(),
2579                       "MiNT port by Guido Flohr, 1997-1999\n");
2580 #endif
2581 #ifdef EPOC
2582         PerlIO_printf(PerlIO_stdout(),
2583                       "EPOC port by Olaf Flebbe, 1999-2002\n");
2584 #endif
2585 #ifdef UNDER_CE
2586         printf("WINCE port by Rainer Keuchel, 2001-2002\n");
2587         printf("Built on " __DATE__ " " __TIME__ "\n\n");
2588         wce_hitreturn();
2589 #endif
2590 #ifdef BINARY_BUILD_NOTICE
2591         BINARY_BUILD_NOTICE;
2592 #endif
2593         PerlIO_printf(PerlIO_stdout(),
2594                       "\n\
2595 Perl may be copied only under the terms of either the Artistic License or the\n\
2596 GNU General Public License, which may be found in the Perl 5 source kit.\n\n\
2597 Complete documentation for Perl, including FAQ lists, should be found on\n\
2598 this system using `man perl' or `perldoc perl'.  If you have access to the\n\
2599 Internet, point your browser at http://www.perl.com/, the Perl Home Page.\n\n");
2600         PerlProc_exit(0);
2601     case 'w':
2602         if (! (PL_dowarn & G_WARN_ALL_MASK))
2603             PL_dowarn |= G_WARN_ON;
2604         s++;
2605         return s;
2606     case 'W':
2607         PL_dowarn = G_WARN_ALL_ON|G_WARN_ON;
2608         if (!specialWARN(PL_compiling.cop_warnings))
2609             SvREFCNT_dec(PL_compiling.cop_warnings);
2610         PL_compiling.cop_warnings = pWARN_ALL ;
2611         s++;
2612         return s;
2613     case 'X':
2614         PL_dowarn = G_WARN_ALL_OFF;
2615         if (!specialWARN(PL_compiling.cop_warnings))
2616             SvREFCNT_dec(PL_compiling.cop_warnings);
2617         PL_compiling.cop_warnings = pWARN_NONE ;
2618         s++;
2619         return s;
2620     case '*':
2621     case ' ':
2622         if (s[1] == '-')        /* Additional switches on #! line. */
2623             return s+2;
2624         break;
2625     case '-':
2626     case 0:
2627 #if defined(WIN32) || !defined(PERL_STRICT_CR)
2628     case '\r':
2629 #endif
2630     case '\n':
2631     case '\t':
2632         break;
2633 #ifdef ALTERNATE_SHEBANG
2634     case 'S':                   /* OS/2 needs -S on "extproc" line. */
2635         break;
2636 #endif
2637     case 'P':
2638         if (PL_preprocess)
2639             return s+1;
2640         /* FALL THROUGH */
2641     default:
2642         Perl_croak(aTHX_ "Can't emulate -%.1s on #! line",s);
2643     }
2644     return Nullch;
2645 }
2646
2647 /* compliments of Tom Christiansen */
2648
2649 /* unexec() can be found in the Gnu emacs distribution */
2650 /* Known to work with -DUNEXEC and using unexelf.c from GNU emacs-20.2 */
2651
2652 void
2653 Perl_my_unexec(pTHX)
2654 {
2655 #ifdef UNEXEC
2656     SV*    prog;
2657     SV*    file;
2658     int    status = 1;
2659     extern int etext;
2660
2661     prog = newSVpv(BIN_EXP, 0);
2662     sv_catpv(prog, "/perl");
2663     file = newSVpv(PL_origfilename, 0);
2664     sv_catpv(file, ".perldump");
2665
2666     unexec(SvPVX(file), SvPVX(prog), &etext, sbrk(0), 0);
2667     /* unexec prints msg to stderr in case of failure */
2668     PerlProc_exit(status);
2669 #else
2670 #  ifdef VMS
2671 #    include <lib$routines.h>
2672      lib$signal(SS$_DEBUG);  /* ssdef.h #included from vmsish.h */
2673 #  else
2674     ABORT();            /* for use with undump */
2675 #  endif
2676 #endif
2677 }
2678
2679 /* initialize curinterp */
2680 STATIC void
2681 S_init_interp(pTHX)
2682 {
2683
2684 #ifdef MULTIPLICITY
2685 #  define PERLVAR(var,type)
2686 #  define PERLVARA(var,n,type)
2687 #  if defined(PERL_IMPLICIT_CONTEXT)
2688 #    if defined(USE_5005THREADS)
2689 #      define PERLVARI(var,type,init)           PERL_GET_INTERP->var = init;
2690 #      define PERLVARIC(var,type,init)  PERL_GET_INTERP->var = init;
2691 #    else /* !USE_5005THREADS */
2692 #      define PERLVARI(var,type,init)           aTHX->var = init;
2693 #      define PERLVARIC(var,type,init)  aTHX->var = init;
2694 #    endif /* USE_5005THREADS */
2695 #  else
2696 #    define PERLVARI(var,type,init)     PERL_GET_INTERP->var = init;
2697 #    define PERLVARIC(var,type,init)    PERL_GET_INTERP->var = init;
2698 #  endif
2699 #  include "intrpvar.h"
2700 #  ifndef USE_5005THREADS
2701 #    include "thrdvar.h"
2702 #  endif
2703 #  undef PERLVAR
2704 #  undef PERLVARA
2705 #  undef PERLVARI
2706 #  undef PERLVARIC
2707 #else
2708 #  define PERLVAR(var,type)
2709 #  define PERLVARA(var,n,type)
2710 #  define PERLVARI(var,type,init)       PL_##var = init;
2711 #  define PERLVARIC(var,type,init)      PL_##var = init;
2712 #  include "intrpvar.h"
2713 #  ifndef USE_5005THREADS
2714 #    include "thrdvar.h"
2715 #  endif
2716 #  undef PERLVAR
2717 #  undef PERLVARA
2718 #  undef PERLVARI
2719 #  undef PERLVARIC
2720 #endif
2721
2722 }
2723
2724 STATIC void
2725 S_init_main_stash(pTHX)
2726 {
2727     GV *gv;
2728
2729     PL_curstash = PL_defstash = newHV();
2730     PL_curstname = newSVpvn("main",4);
2731     gv = gv_fetchpv("main::",TRUE, SVt_PVHV);
2732     SvREFCNT_dec(GvHV(gv));
2733     GvHV(gv) = (HV*)SvREFCNT_inc(PL_defstash);
2734     SvREADONLY_on(gv);
2735     HvNAME(PL_defstash) = savepv("main");
2736     PL_incgv = gv_HVadd(gv_AVadd(gv_fetchpv("INC",TRUE, SVt_PVAV)));
2737     GvMULTI_on(PL_incgv);
2738     PL_hintgv = gv_fetchpv("\010",TRUE, SVt_PV); /* ^H */
2739     GvMULTI_on(PL_hintgv);
2740     PL_defgv = gv_fetchpv("_",TRUE, SVt_PVAV);
2741     PL_errgv = gv_HVadd(gv_fetchpv("@", TRUE, SVt_PV));
2742     GvMULTI_on(PL_errgv);
2743     PL_replgv = gv_fetchpv("\022", TRUE, SVt_PV); /* ^R */
2744     GvMULTI_on(PL_replgv);
2745     (void)Perl_form(aTHX_ "%240s","");  /* Preallocate temp - for immediate signals. */
2746     sv_grow(ERRSV, 240);        /* Preallocate - for immediate signals. */
2747     sv_setpvn(ERRSV, "", 0);
2748     PL_curstash = PL_defstash;
2749     CopSTASH_set(&PL_compiling, PL_defstash);
2750     PL_debstash = GvHV(gv_fetchpv("DB::", GV_ADDMULTI, SVt_PVHV));
2751     PL_globalstash = GvHV(gv_fetchpv("CORE::GLOBAL::", GV_ADDMULTI, SVt_PVHV));
2752     PL_nullstash = GvHV(gv_fetchpv("<none>::", GV_ADDMULTI, SVt_PVHV));
2753     /* We must init $/ before switches are processed. */
2754     sv_setpvn(get_sv("/", TRUE), "\n", 1);
2755 }
2756
2757 STATIC void
2758 S_open_script(pTHX_ char *scriptname, bool dosearch, SV *sv, int *fdscript)
2759 {
2760     char *quote;
2761     char *code;
2762     char *cpp_discard_flag;
2763     char *perl;
2764
2765     *fdscript = -1;
2766
2767     if (PL_e_script) {
2768         PL_origfilename = savepv("-e");
2769     }
2770     else {
2771         /* if find_script() returns, it returns a malloc()-ed value */
2772         PL_origfilename = scriptname = find_script(scriptname, dosearch, NULL, 1);
2773
2774         if (strnEQ(scriptname, "/dev/fd/", 8) && isDIGIT(scriptname[8]) ) {
2775             char *s = scriptname + 8;
2776             *fdscript = atoi(s);
2777             while (isDIGIT(*s))
2778                 s++;
2779             if (*s) {
2780                 scriptname = savepv(s + 1);
2781                 Safefree(PL_origfilename);
2782                 PL_origfilename = scriptname;
2783             }
2784         }
2785     }
2786
2787     CopFILE_free(PL_curcop);
2788     CopFILE_set(PL_curcop, PL_origfilename);
2789     if (strEQ(PL_origfilename,"-"))
2790         scriptname = "";
2791     if (*fdscript >= 0) {
2792         PL_rsfp = PerlIO_fdopen(*fdscript,PERL_SCRIPT_MODE);
2793 #       if defined(HAS_FCNTL) && defined(F_SETFD)
2794             if (PL_rsfp)
2795                 /* ensure close-on-exec */
2796                 fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,1);
2797 #       endif
2798     }
2799     else if (PL_preprocess) {
2800         char *cpp_cfg = CPPSTDIN;
2801         SV *cpp = newSVpvn("",0);
2802         SV *cmd = NEWSV(0,0);
2803
2804         if (strEQ(cpp_cfg, "cppstdin"))
2805             Perl_sv_catpvf(aTHX_ cpp, "%s/", BIN_EXP);
2806         sv_catpv(cpp, cpp_cfg);
2807
2808 #       ifndef VMS
2809             sv_catpvn(sv, "-I", 2);
2810             sv_catpv(sv,PRIVLIB_EXP);
2811 #       endif
2812
2813         DEBUG_P(PerlIO_printf(Perl_debug_log,
2814                               "PL_preprocess: scriptname=\"%s\", cpp=\"%s\", sv=\"%s\", CPPMINUS=\"%s\"\n",
2815                               scriptname, SvPVX (cpp), SvPVX (sv), CPPMINUS));
2816
2817 #       if defined(MSDOS) || defined(WIN32) || defined(VMS)
2818             quote = "\"";
2819 #       else
2820             quote = "'";
2821 #       endif
2822
2823 #       ifdef VMS
2824             cpp_discard_flag = "";
2825 #       else
2826             cpp_discard_flag = "-C";
2827 #       endif
2828
2829 #       ifdef OS2
2830             perl = os2_execname(aTHX);
2831 #       else
2832             perl = PL_origargv[0];
2833 #       endif
2834
2835
2836         /* This strips off Perl comments which might interfere with
2837            the C pre-processor, including #!.  #line directives are
2838            deliberately stripped to avoid confusion with Perl's version
2839            of #line.  FWP played some golf with it so it will fit
2840            into VMS's 255 character buffer.
2841         */
2842         if( PL_doextract )
2843             code = "(1../^#!.*perl/i)|/^\\s*#(?!\\s*((ifn?|un)def|(el|end)?if|define|include|else|error|pragma)\\b)/||!($|=1)||print";
2844         else
2845             code = "/^\\s*#(?!\\s*((ifn?|un)def|(el|end)?if|define|include|else|error|pragma)\\b)/||!($|=1)||print";
2846
2847         Perl_sv_setpvf(aTHX_ cmd, "\
2848 %s -ne%s%s%s %s | %"SVf" %s %"SVf" %s",
2849                        perl, quote, code, quote, scriptname, cpp,
2850                        cpp_discard_flag, sv, CPPMINUS);
2851
2852         PL_doextract = FALSE;
2853 #       ifdef IAMSUID                   /* actually, this is caught earlier */
2854             if (PL_euid != PL_uid && !PL_euid) {  /* if running suidperl */
2855 #               ifdef HAS_SETEUID
2856                     (void)seteuid(PL_uid);        /* musn't stay setuid root */
2857 #               else
2858 #               ifdef HAS_SETREUID
2859                     (void)setreuid((Uid_t)-1, PL_uid);
2860 #               else
2861 #               ifdef HAS_SETRESUID
2862                     (void)setresuid((Uid_t)-1, PL_uid, (Uid_t)-1);
2863 #               else
2864                     PerlProc_setuid(PL_uid);
2865 #               endif
2866 #               endif
2867 #               endif
2868             if (PerlProc_geteuid() != PL_uid)
2869                 Perl_croak(aTHX_ "Can't do seteuid!\n");
2870         }
2871 #       endif /* IAMSUID */
2872
2873         DEBUG_P(PerlIO_printf(Perl_debug_log,
2874                               "PL_preprocess: cmd=\"%s\"\n",
2875                               SvPVX(cmd)));
2876
2877         PL_rsfp = PerlProc_popen(SvPVX(cmd), "r");
2878         SvREFCNT_dec(cmd);
2879         SvREFCNT_dec(cpp);
2880     }
2881     else if (!*scriptname) {
2882         forbid_setid("program input from stdin");
2883         PL_rsfp = PerlIO_stdin();
2884     }
2885     else {
2886         PL_rsfp = PerlIO_open(scriptname,PERL_SCRIPT_MODE);
2887 #       if defined(HAS_FCNTL) && defined(F_SETFD)
2888             if (PL_rsfp)
2889                 /* ensure close-on-exec */
2890                 fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,1);
2891 #       endif
2892     }
2893     if (!PL_rsfp) {
2894 #       ifdef DOSUID
2895 #       ifndef IAMSUID  /* in case script is not readable before setuid */
2896             if (PL_euid &&
2897                 PerlLIO_stat(CopFILE(PL_curcop),&PL_statbuf) >= 0 &&
2898                 PL_statbuf.st_mode & (S_ISUID|S_ISGID))
2899             {
2900                 /* try again */
2901                 PerlProc_execv(Perl_form(aTHX_ "%s/sperl"PERL_FS_VER_FMT,
2902                                          BIN_EXP, (int)PERL_REVISION,
2903                                          (int)PERL_VERSION,
2904                                          (int)PERL_SUBVERSION), PL_origargv);
2905                 Perl_croak(aTHX_ "Can't do setuid\n");
2906             }
2907 #       endif
2908 #       endif
2909 #       ifdef IAMSUID
2910             errno = EPERM;
2911             Perl_croak(aTHX_ "Can't open perl script: %s\n",
2912                        Strerror(errno));
2913 #       else
2914             Perl_croak(aTHX_ "Can't open perl script \"%s\": %s\n",
2915                        CopFILE(PL_curcop), Strerror(errno));
2916 #       endif
2917     }
2918 }
2919
2920 /* Mention
2921  * I_SYSSTATVFS HAS_FSTATVFS
2922  * I_SYSMOUNT
2923  * I_STATFS     HAS_FSTATFS     HAS_GETFSSTAT
2924  * I_MNTENT     HAS_GETMNTENT   HAS_HASMNTOPT
2925  * here so that metaconfig picks them up. */
2926
2927 #ifdef IAMSUID
2928 STATIC int
2929 S_fd_on_nosuid_fs(pTHX_ int fd)
2930 {
2931     int check_okay = 0; /* able to do all the required sys/libcalls */
2932     int on_nosuid  = 0; /* the fd is on a nosuid fs */
2933 /*
2934  * Preferred order: fstatvfs(), fstatfs(), ustat()+getmnt(), getmntent().
2935  * fstatvfs() is UNIX98.
2936  * fstatfs() is 4.3 BSD.
2937  * ustat()+getmnt() is pre-4.3 BSD.
2938  * getmntent() is O(number-of-mounted-filesystems) and can hang on
2939  * an irrelevant filesystem while trying to reach the right one.
2940  */
2941
2942 #undef FD_ON_NOSUID_CHECK_OKAY  /* found the syscalls to do the check? */
2943
2944 #   if !defined(FD_ON_NOSUID_CHECK_OKAY) && \
2945         defined(HAS_FSTATVFS)
2946 #   define FD_ON_NOSUID_CHECK_OKAY
2947     struct statvfs stfs;
2948
2949     check_okay = fstatvfs(fd, &stfs) == 0;
2950     on_nosuid  = check_okay && (stfs.f_flag  & ST_NOSUID);
2951 #   endif /* fstatvfs */
2952
2953 #   if !defined(FD_ON_NOSUID_CHECK_OKAY) && \
2954         defined(PERL_MOUNT_NOSUID)      && \
2955         defined(HAS_FSTATFS)            && \
2956         defined(HAS_STRUCT_STATFS)      && \
2957         defined(HAS_STRUCT_STATFS_F_FLAGS)
2958 #   define FD_ON_NOSUID_CHECK_OKAY
2959     struct statfs  stfs;
2960
2961     check_okay = fstatfs(fd, &stfs)  == 0;
2962     on_nosuid  = check_okay && (stfs.f_flags & PERL_MOUNT_NOSUID);
2963 #   endif /* fstatfs */
2964
2965 #   if !defined(FD_ON_NOSUID_CHECK_OKAY) && \
2966         defined(PERL_MOUNT_NOSUID)      && \
2967         defined(HAS_FSTAT)              && \
2968         defined(HAS_USTAT)              && \
2969         defined(HAS_GETMNT)             && \
2970         defined(HAS_STRUCT_FS_DATA)     && \
2971         defined(NOSTAT_ONE)
2972 #   define FD_ON_NOSUID_CHECK_OKAY
2973     Stat_t fdst;
2974
2975     if (fstat(fd, &fdst) == 0) {
2976         struct ustat us;
2977         if (ustat(fdst.st_dev, &us) == 0) {
2978             struct fs_data fsd;
2979             /* NOSTAT_ONE here because we're not examining fields which
2980              * vary between that case and STAT_ONE. */
2981             if (getmnt((int*)0, &fsd, (int)0, NOSTAT_ONE, us.f_fname) == 0) {
2982                 size_t cmplen = sizeof(us.f_fname);
2983                 if (sizeof(fsd.fd_req.path) < cmplen)
2984                     cmplen = sizeof(fsd.fd_req.path);
2985                 if (strnEQ(fsd.fd_req.path, us.f_fname, cmplen) &&
2986                     fdst.st_dev == fsd.fd_req.dev) {
2987                         check_okay = 1;
2988                         on_nosuid = fsd.fd_req.flags & PERL_MOUNT_NOSUID;
2989                     }
2990                 }
2991             }
2992         }
2993     }
2994 #   endif /* fstat+ustat+getmnt */
2995
2996 #   if !defined(FD_ON_NOSUID_CHECK_OKAY) && \
2997         defined(HAS_GETMNTENT)          && \
2998         defined(HAS_HASMNTOPT)          && \
2999         defined(MNTOPT_NOSUID)
3000 #   define FD_ON_NOSUID_CHECK_OKAY
3001     FILE                *mtab = fopen("/etc/mtab", "r");
3002     struct mntent       *entry;
3003     Stat_t              stb, fsb;
3004
3005     if (mtab && (fstat(fd, &stb) == 0)) {
3006         while (entry = getmntent(mtab)) {
3007             if (stat(entry->mnt_dir, &fsb) == 0
3008                 && fsb.st_dev == stb.st_dev)
3009             {
3010                 /* found the filesystem */
3011                 check_okay = 1;
3012                 if (hasmntopt(entry, MNTOPT_NOSUID))
3013                     on_nosuid = 1;
3014                 break;
3015             } /* A single fs may well fail its stat(). */
3016         }
3017     }
3018     if (mtab)
3019         fclose(mtab);
3020 #   endif /* getmntent+hasmntopt */
3021
3022     if (!check_okay)
3023         Perl_croak(aTHX_ "Can't check filesystem of script \"%s\" for nosuid", PL_origfilename);
3024     return on_nosuid;
3025 }
3026 #endif /* IAMSUID */
3027
3028 STATIC void
3029 S_validate_suid(pTHX_ char *validarg, char *scriptname, int fdscript)
3030 {
3031 #ifdef IAMSUID
3032     int which;
3033 #endif
3034
3035     /* do we need to emulate setuid on scripts? */
3036
3037     /* This code is for those BSD systems that have setuid #! scripts disabled
3038      * in the kernel because of a security problem.  Merely defining DOSUID
3039      * in perl will not fix that problem, but if you have disabled setuid
3040      * scripts in the kernel, this will attempt to emulate setuid and setgid
3041      * on scripts that have those now-otherwise-useless bits set.  The setuid
3042      * root version must be called suidperl or sperlN.NNN.  If regular perl
3043      * discovers that it has opened a setuid script, it calls suidperl with
3044      * the same argv that it had.  If suidperl finds that the script it has
3045      * just opened is NOT setuid root, it sets the effective uid back to the
3046      * uid.  We don't just make perl setuid root because that loses the
3047      * effective uid we had before invoking perl, if it was different from the
3048      * uid.
3049      *
3050      * DOSUID must be defined in both perl and suidperl, and IAMSUID must
3051      * be defined in suidperl only.  suidperl must be setuid root.  The
3052      * Configure script will set this up for you if you want it.
3053      */
3054
3055 #ifdef DOSUID
3056     char *s, *s2;
3057
3058     if (PerlLIO_fstat(PerlIO_fileno(PL_rsfp),&PL_statbuf) < 0)  /* normal stat is insecure */
3059         Perl_croak(aTHX_ "Can't stat script \"%s\"",PL_origfilename);
3060     if (fdscript < 0 && PL_statbuf.st_mode & (S_ISUID|S_ISGID)) {
3061         I32 len;
3062         STRLEN n_a;
3063
3064 #ifdef IAMSUID
3065 #ifndef HAS_SETREUID
3066         /* On this access check to make sure the directories are readable,
3067          * there is actually a small window that the user could use to make
3068          * filename point to an accessible directory.  So there is a faint
3069          * chance that someone could execute a setuid script down in a
3070          * non-accessible directory.  I don't know what to do about that.
3071          * But I don't think it's too important.  The manual lies when
3072          * it says access() is useful in setuid programs.
3073          */
3074         if (PerlLIO_access(CopFILE(PL_curcop),1)) /*double check*/
3075             Perl_croak(aTHX_ "Permission denied");
3076 #else
3077         /* If we can swap euid and uid, then we can determine access rights
3078          * with a simple stat of the file, and then compare device and
3079          * inode to make sure we did stat() on the same file we opened.
3080          * Then we just have to make sure he or she can execute it.
3081          */
3082         {
3083             Stat_t tmpstatbuf;
3084
3085             if (
3086 #ifdef HAS_SETREUID
3087                 setreuid(PL_euid,PL_uid) < 0
3088 #else
3089 # if HAS_SETRESUID
3090                 setresuid(PL_euid,PL_uid,(Uid_t)-1) < 0
3091 # endif
3092 #endif
3093                 || PerlProc_getuid() != PL_euid || PerlProc_geteuid() != PL_uid)
3094                 Perl_croak(aTHX_ "Can't swap uid and euid");    /* really paranoid */
3095             if (PerlLIO_stat(CopFILE(PL_curcop),&tmpstatbuf) < 0)
3096                 Perl_croak(aTHX_ "Permission denied");  /* testing full pathname here */
3097 #if defined(IAMSUID) && !defined(NO_NOSUID_CHECK)
3098             if (fd_on_nosuid_fs(PerlIO_fileno(PL_rsfp)))
3099                 Perl_croak(aTHX_ "Permission denied");
3100 #endif
3101             if (tmpstatbuf.st_dev != PL_statbuf.st_dev ||
3102                 tmpstatbuf.st_ino != PL_statbuf.st_ino) {
3103                 (void)PerlIO_close(PL_rsfp);
3104                 Perl_croak(aTHX_ "Permission denied\n");
3105             }
3106             if (
3107 #ifdef HAS_SETREUID
3108               setreuid(PL_uid,PL_euid) < 0
3109 #else
3110 # if defined(HAS_SETRESUID)
3111               setresuid(PL_uid,PL_euid,(Uid_t)-1) < 0
3112 # endif
3113 #endif
3114               || PerlProc_getuid() != PL_uid || PerlProc_geteuid() != PL_euid)
3115                 Perl_croak(aTHX_ "Can't reswap uid and euid");
3116             if (!cando(S_IXUSR,FALSE,&PL_statbuf))              /* can real uid exec? */
3117                 Perl_croak(aTHX_ "Permission denied\n");
3118         }
3119 #endif /* HAS_SETREUID */
3120 #endif /* IAMSUID */
3121
3122         if (!S_ISREG(PL_statbuf.st_mode))
3123             Perl_croak(aTHX_ "Permission denied");
3124         if (PL_statbuf.st_mode & S_IWOTH)
3125             Perl_croak(aTHX_ "Setuid/gid script is writable by world");
3126         PL_doswitches = FALSE;          /* -s is insecure in suid */
3127         CopLINE_inc(PL_curcop);
3128         if (sv_gets(PL_linestr, PL_rsfp, 0) == Nullch ||
3129           strnNE(SvPV(PL_linestr,n_a),"#!",2) ) /* required even on Sys V */
3130             Perl_croak(aTHX_ "No #! line");
3131         s = SvPV(PL_linestr,n_a)+2;
3132         if (*s == ' ') s++;
3133         while (!isSPACE(*s)) s++;
3134         for (s2 = s;  (s2 > SvPV(PL_linestr,n_a)+2 &&
3135                        (isDIGIT(s2[-1]) || strchr("._-", s2[-1])));  s2--) ;
3136         if (strnNE(s2-4,"perl",4) && strnNE(s-9,"perl",4))  /* sanity check */
3137             Perl_croak(aTHX_ "Not a perl script");
3138         while (*s == ' ' || *s == '\t') s++;
3139         /*
3140          * #! arg must be what we saw above.  They can invoke it by
3141          * mentioning suidperl explicitly, but they may not add any strange
3142          * arguments beyond what #! says if they do invoke suidperl that way.
3143          */
3144         len = strlen(validarg);
3145         if (strEQ(validarg," PHOOEY ") ||
3146             strnNE(s,validarg,len) || !isSPACE(s[len]))
3147             Perl_croak(aTHX_ "Args must match #! line");
3148
3149 #ifndef IAMSUID
3150         if (PL_euid != PL_uid && (PL_statbuf.st_mode & S_ISUID) &&
3151             PL_euid == PL_statbuf.st_uid)
3152             if (!PL_do_undump)
3153                 Perl_croak(aTHX_ "YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
3154 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
3155 #endif /* IAMSUID */
3156
3157         if (PL_euid) {  /* oops, we're not the setuid root perl */
3158             (void)PerlIO_close(PL_rsfp);
3159 #ifndef IAMSUID
3160             /* try again */
3161             PerlProc_execv(Perl_form(aTHX_ "%s/sperl"PERL_FS_VER_FMT, BIN_EXP,
3162                                      (int)PERL_REVISION, (int)PERL_VERSION,
3163                                      (int)PERL_SUBVERSION), PL_origargv);
3164 #endif
3165             Perl_croak(aTHX_ "Can't do setuid\n");
3166         }
3167
3168         if (PL_statbuf.st_mode & S_ISGID && PL_statbuf.st_gid != PL_egid) {
3169 #ifdef HAS_SETEGID
3170             (void)setegid(PL_statbuf.st_gid);
3171 #else
3172 #ifdef HAS_SETREGID
3173            (void)setregid((Gid_t)-1,PL_statbuf.st_gid);
3174 #else
3175 #ifdef HAS_SETRESGID
3176            (void)setresgid((Gid_t)-1,PL_statbuf.st_gid,(Gid_t)-1);
3177 #else
3178             PerlProc_setgid(PL_statbuf.st_gid);
3179 #endif
3180 #endif
3181 #endif
3182             if (PerlProc_getegid() != PL_statbuf.st_gid)
3183                 Perl_croak(aTHX_ "Can't do setegid!\n");
3184         }
3185         if (PL_statbuf.st_mode & S_ISUID) {
3186             if (PL_statbuf.st_uid != PL_euid)
3187 #ifdef HAS_SETEUID
3188                 (void)seteuid(PL_statbuf.st_uid);       /* all that for this */
3189 #else
3190 #ifdef HAS_SETREUID
3191                 (void)setreuid((Uid_t)-1,PL_statbuf.st_uid);
3192 #else
3193 #ifdef HAS_SETRESUID
3194                 (void)setresuid((Uid_t)-1,PL_statbuf.st_uid,(Uid_t)-1);
3195 #else
3196                 PerlProc_setuid(PL_statbuf.st_uid);
3197 #endif
3198 #endif
3199 #endif
3200             if (PerlProc_geteuid() != PL_statbuf.st_uid)
3201                 Perl_croak(aTHX_ "Can't do seteuid!\n");
3202         }
3203         else if (PL_uid) {                      /* oops, mustn't run as root */
3204 #ifdef HAS_SETEUID
3205           (void)seteuid((Uid_t)PL_uid);
3206 #else
3207 #ifdef HAS_SETREUID
3208           (void)setreuid((Uid_t)-1,(Uid_t)PL_uid);
3209 #else
3210 #ifdef HAS_SETRESUID
3211           (void)setresuid((Uid_t)-1,(Uid_t)PL_uid,(Uid_t)-1);
3212 #else
3213           PerlProc_setuid((Uid_t)PL_uid);
3214 #endif
3215 #endif
3216 #endif
3217             if (PerlProc_geteuid() != PL_uid)
3218                 Perl_croak(aTHX_ "Can't do seteuid!\n");
3219         }
3220         init_ids();
3221         if (!cando(S_IXUSR,TRUE,&PL_statbuf))
3222             Perl_croak(aTHX_ "Permission denied\n");    /* they can't do this */
3223     }
3224 #ifdef IAMSUID
3225     else if (PL_preprocess)
3226         Perl_croak(aTHX_ "-P not allowed for setuid/setgid script\n");
3227     else if (fdscript >= 0)
3228         Perl_croak(aTHX_ "fd script not allowed in suidperl\n");
3229     else
3230         Perl_croak(aTHX_ "Script is not setuid/setgid in suidperl\n");
3231
3232     /* We absolutely must clear out any saved ids here, so we */
3233     /* exec the real perl, substituting fd script for scriptname. */
3234     /* (We pass script name as "subdir" of fd, which perl will grok.) */
3235     PerlIO_rewind(PL_rsfp);
3236     PerlLIO_lseek(PerlIO_fileno(PL_rsfp),(Off_t)0,0);  /* just in case rewind didn't */
3237     for (which = 1; PL_origargv[which] && PL_origargv[which] != scriptname; which++) ;
3238     if (!PL_origargv[which])
3239         Perl_croak(aTHX_ "Permission denied");
3240     PL_origargv[which] = savepv(Perl_form(aTHX_ "/dev/fd/%d/%s",
3241                                   PerlIO_fileno(PL_rsfp), PL_origargv[which]));
3242 #if defined(HAS_FCNTL) && defined(F_SETFD)
3243     fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,0);    /* ensure no close-on-exec */
3244 #endif
3245     PerlProc_execv(Perl_form(aTHX_ "%s/perl"PERL_FS_VER_FMT, BIN_EXP,
3246                              (int)PERL_REVISION, (int)PERL_VERSION,
3247                              (int)PERL_SUBVERSION), PL_origargv);/* try again */
3248     Perl_croak(aTHX_ "Can't do setuid\n");
3249 #endif /* IAMSUID */
3250 #else /* !DOSUID */
3251     if (PL_euid != PL_uid || PL_egid != PL_gid) {       /* (suidperl doesn't exist, in fact) */
3252 #ifndef SETUID_SCRIPTS_ARE_SECURE_NOW
3253         PerlLIO_fstat(PerlIO_fileno(PL_rsfp),&PL_statbuf);      /* may be either wrapped or real suid */
3254         if ((PL_euid != PL_uid && PL_euid == PL_statbuf.st_uid && PL_statbuf.st_mode & S_ISUID)
3255             ||
3256             (PL_egid != PL_gid && PL_egid == PL_statbuf.st_gid && PL_statbuf.st_mode & S_ISGID)
3257            )
3258             if (!PL_do_undump)
3259                 Perl_croak(aTHX_ "YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
3260 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
3261 #endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
3262         /* not set-id, must be wrapped */
3263     }
3264 #endif /* DOSUID */
3265 }
3266
3267 STATIC void
3268 S_find_beginning(pTHX)
3269 {
3270     register char *s, *s2;
3271
3272     /* skip forward in input to the real script? */
3273
3274     forbid_setid("-x");
3275 #ifdef MACOS_TRADITIONAL
3276     /* Since the Mac OS does not honor #! arguments for us, we do it ourselves */
3277
3278     while (PL_doextract || gMacPerl_AlwaysExtract) {
3279         if ((s = sv_gets(PL_linestr, PL_rsfp, 0)) == Nullch) {
3280             if (!gMacPerl_AlwaysExtract)
3281                 Perl_croak(aTHX_ "No Perl script found in input\n");
3282
3283             if (PL_doextract)                   /* require explicit override ? */
3284                 if (!OverrideExtract(PL_origfilename))
3285                     Perl_croak(aTHX_ "User aborted script\n");
3286                 else
3287                     PL_doextract = FALSE;
3288
3289             /* Pater peccavi, file does not have #! */
3290             PerlIO_rewind(PL_rsfp);
3291
3292             break;
3293         }
3294 #else
3295     while (PL_doextract) {
3296         if ((s = sv_gets(PL_linestr, PL_rsfp, 0)) == Nullch)
3297             Perl_croak(aTHX_ "No Perl script found in input\n");
3298 #endif
3299         s2 = s;
3300         if (*s == '#' && s[1] == '!' && ((s = instr(s,"perl")) || (s = instr(s2,"PERL")))) {
3301             PerlIO_ungetc(PL_rsfp, '\n');               /* to keep line count right */
3302             PL_doextract = FALSE;
3303             while (*s && !(isSPACE (*s) || *s == '#')) s++;
3304             s2 = s;
3305             while (*s == ' ' || *s == '\t') s++;
3306             if (*s++ == '-') {
3307                 while (isDIGIT(s2[-1]) || strchr("-._", s2[-1])) s2--;
3308                 if (strnEQ(s2-4,"perl",4))
3309                     /*SUPPRESS 530*/
3310                     while ((s = moreswitches(s)))
3311                         ;
3312             }
3313 #ifdef MACOS_TRADITIONAL
3314             break;
3315 #endif
3316         }
3317     }
3318 }
3319
3320
3321 STATIC void
3322 S_init_ids(pTHX)
3323 {
3324     PL_uid = PerlProc_getuid();
3325     PL_euid = PerlProc_geteuid();
3326     PL_gid = PerlProc_getgid();
3327     PL_egid = PerlProc_getegid();
3328 #ifdef VMS
3329     PL_uid |= PL_gid << 16;
3330     PL_euid |= PL_egid << 16;
3331 #endif
3332     PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
3333 }
3334
3335 STATIC void
3336 S_forbid_setid(pTHX_ char *s)
3337 {
3338     if (PL_euid != PL_uid)
3339         Perl_croak(aTHX_ "No %s allowed while running setuid", s);
3340     if (PL_egid != PL_gid)
3341         Perl_croak(aTHX_ "No %s allowed while running setgid", s);
3342 }
3343
3344 void
3345 Perl_init_debugger(pTHX)
3346 {
3347     HV *ostash = PL_curstash;
3348
3349     PL_curstash = PL_debstash;
3350     PL_dbargs = GvAV(gv_AVadd((gv_fetchpv("args", GV_ADDMULTI, SVt_PVAV))));
3351     AvREAL_off(PL_dbargs);
3352     PL_DBgv = gv_fetchpv("DB", GV_ADDMULTI, SVt_PVGV);
3353     PL_DBline = gv_fetchpv("dbline", GV_ADDMULTI, SVt_PVAV);
3354     PL_DBsub = gv_HVadd(gv_fetchpv("sub", GV_ADDMULTI, SVt_PVHV));
3355     sv_upgrade(GvSV(PL_DBsub), SVt_IV); /* IVX accessed if PERLDB_SUB_NN */
3356     PL_DBsingle = GvSV((gv_fetchpv("single", GV_ADDMULTI, SVt_PV)));
3357     sv_setiv(PL_DBsingle, 0);
3358     PL_DBtrace = GvSV((gv_fetchpv("trace", GV_ADDMULTI, SVt_PV)));
3359     sv_setiv(PL_DBtrace, 0);
3360     PL_DBsignal = GvSV((gv_fetchpv("signal", GV_ADDMULTI, SVt_PV)));
3361     sv_setiv(PL_DBsignal, 0);
3362     PL_curstash = ostash;
3363 }
3364
3365 #ifndef STRESS_REALLOC
3366 #define REASONABLE(size) (size)
3367 #else
3368 #define REASONABLE(size) (1) /* unreasonable */
3369 #endif
3370
3371 void
3372 Perl_init_stacks(pTHX)
3373 {
3374     /* start with 128-item stack and 8K cxstack */
3375     PL_curstackinfo = new_stackinfo(REASONABLE(128),
3376                                  REASONABLE(8192/sizeof(PERL_CONTEXT) - 1));
3377     PL_curstackinfo->si_type = PERLSI_MAIN;
3378     PL_curstack = PL_curstackinfo->si_stack;
3379     PL_mainstack = PL_curstack;         /* remember in case we switch stacks */
3380
3381     PL_stack_base = AvARRAY(PL_curstack);
3382     PL_stack_sp = PL_stack_base;
3383     PL_stack_max = PL_stack_base + AvMAX(PL_curstack);
3384
3385     New(50,PL_tmps_stack,REASONABLE(128),SV*);
3386     PL_tmps_floor = -1;
3387     PL_tmps_ix = -1;
3388     PL_tmps_max = REASONABLE(128);
3389
3390     New(54,PL_markstack,REASONABLE(32),I32);
3391     PL_markstack_ptr = PL_markstack;
3392     PL_markstack_max = PL_markstack + REASONABLE(32);
3393
3394     SET_MARK_OFFSET;
3395
3396     New(54,PL_scopestack,REASONABLE(32),I32);
3397     PL_scopestack_ix = 0;
3398     PL_scopestack_max = REASONABLE(32);
3399
3400     New(54,PL_savestack,REASONABLE(128),ANY);
3401     PL_savestack_ix = 0;
3402     PL_savestack_max = REASONABLE(128);
3403
3404     New(54,PL_retstack,REASONABLE(16),OP*);
3405     PL_retstack_ix = 0;
3406     PL_retstack_max = REASONABLE(16);
3407 }
3408
3409 #undef REASONABLE
3410
3411 STATIC void
3412 S_nuke_stacks(pTHX)
3413 {
3414     while (PL_curstackinfo->si_next)
3415         PL_curstackinfo = PL_curstackinfo->si_next;
3416     while (PL_curstackinfo) {
3417         PERL_SI *p = PL_curstackinfo->si_prev;
3418         /* curstackinfo->si_stack got nuked by sv_free_arenas() */
3419         Safefree(PL_curstackinfo->si_cxstack);
3420         Safefree(PL_curstackinfo);
3421         PL_curstackinfo = p;
3422     }
3423     Safefree(PL_tmps_stack);
3424     Safefree(PL_markstack);
3425     Safefree(PL_scopestack);
3426     Safefree(PL_savestack);
3427     Safefree(PL_retstack);
3428 }
3429
3430 STATIC void
3431 S_init_lexer(pTHX)
3432 {
3433     PerlIO *tmpfp;
3434     tmpfp = PL_rsfp;
3435     PL_rsfp = Nullfp;
3436     lex_start(PL_linestr);
3437     PL_rsfp = tmpfp;
3438     PL_subname = newSVpvn("main",4);
3439 }
3440
3441 STATIC void
3442 S_init_predump_symbols(pTHX)
3443 {
3444     GV *tmpgv;
3445     IO *io;
3446
3447     sv_setpvn(get_sv("\"", TRUE), " ", 1);
3448     PL_stdingv = gv_fetchpv("STDIN",TRUE, SVt_PVIO);
3449     GvMULTI_on(PL_stdingv);
3450     io = GvIOp(PL_stdingv);
3451     IoTYPE(io) = IoTYPE_RDONLY;
3452     IoIFP(io) = PerlIO_stdin();
3453     tmpgv = gv_fetchpv("stdin",TRUE, SVt_PV);
3454     GvMULTI_on(tmpgv);
3455     GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io);
3456
3457     tmpgv = gv_fetchpv("STDOUT",TRUE, SVt_PVIO);
3458     GvMULTI_on(tmpgv);
3459     io = GvIOp(tmpgv);
3460     IoTYPE(io) = IoTYPE_WRONLY;
3461     IoOFP(io) = IoIFP(io) = PerlIO_stdout();
3462     setdefout(tmpgv);
3463     tmpgv = gv_fetchpv("stdout",TRUE, SVt_PV);
3464     GvMULTI_on(tmpgv);
3465     GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io);
3466
3467     PL_stderrgv = gv_fetchpv("STDERR",TRUE, SVt_PVIO);
3468     GvMULTI_on(PL_stderrgv);
3469     io = GvIOp(PL_stderrgv);
3470     IoTYPE(io) = IoTYPE_WRONLY;
3471     IoOFP(io) = IoIFP(io) = PerlIO_stderr();
3472     tmpgv = gv_fetchpv("stderr",TRUE, SVt_PV);
3473     GvMULTI_on(tmpgv);
3474     GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io);
3475
3476     PL_statname = NEWSV(66,0);          /* last filename we did stat on */
3477
3478     if (PL_osname)
3479         Safefree(PL_osname);
3480     PL_osname = savepv(OSNAME);
3481 }
3482
3483 void
3484 Perl_init_argv_symbols(pTHX_ register int argc, register char **argv)
3485 {
3486     char *s;
3487     argc--,argv++;      /* skip name of script */
3488     if (PL_doswitches) {
3489         for (; argc > 0 && **argv == '-'; argc--,argv++) {
3490             if (!argv[0][1])
3491                 break;
3492             if (argv[0][1] == '-' && !argv[0][2]) {
3493                 argc--,argv++;
3494                 break;
3495             }
3496             if ((s = strchr(argv[0], '='))) {
3497                 *s++ = '\0';
3498                 sv_setpv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),s);
3499             }
3500             else
3501                 sv_setiv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),1);
3502         }
3503     }
3504     if ((PL_argvgv = gv_fetchpv("ARGV",TRUE, SVt_PVAV))) {
3505         GvMULTI_on(PL_argvgv);
3506         (void)gv_AVadd(PL_argvgv);
3507         av_clear(GvAVn(PL_argvgv));
3508         for (; argc > 0; argc--,argv++) {
3509             SV *sv = newSVpv(argv[0],0);
3510             av_push(GvAVn(PL_argvgv),sv);
3511             if (PL_widesyscalls)
3512                 (void)sv_utf8_decode(sv);
3513         }
3514     }
3515 }
3516
3517 #ifdef HAS_PROCSELFEXE
3518 /* This is a function so that we don't hold on to MAXPATHLEN
3519    bytes of stack longer than necessary
3520  */
3521 STATIC void
3522 S_procself_val(pTHX_ SV *sv, char *arg0)
3523 {
3524     char buf[MAXPATHLEN];
3525     int len = readlink(PROCSELFEXE_PATH, buf, sizeof(buf) - 1);
3526     /* FreeBSD's implementation is acknowledged to be imperfect, sometimes
3527        returning the text "unknown" from the readlink rather than the path
3528        to the executable (or returning an error from the readlink).  Any valid
3529        path has a '/' in it somewhere, so use that to validate the result.
3530        See http://www.freebsd.org/cgi/query-pr.cgi?pr=35703
3531     */
3532     if (len > 0 && memchr(buf, '/', len)) {
3533         sv_setpvn(sv,buf,len);
3534     }
3535     else {
3536         sv_setpv(sv,arg0);
3537     }
3538 }
3539 #endif /* HAS_PROCSELFEXE */
3540
3541 STATIC void
3542 S_init_postdump_symbols(pTHX_ register int argc, register char **argv, register char **env)
3543 {
3544     char *s;
3545     SV *sv;
3546     GV* tmpgv;
3547
3548     PL_toptarget = NEWSV(0,0);
3549     sv_upgrade(PL_toptarget, SVt_PVFM);
3550     sv_setpvn(PL_toptarget, "", 0);
3551     PL_bodytarget = NEWSV(0,0);
3552     sv_upgrade(PL_bodytarget, SVt_PVFM);
3553     sv_setpvn(PL_bodytarget, "", 0);
3554     PL_formtarget = PL_bodytarget;
3555
3556     TAINT;
3557
3558     init_argv_symbols(argc,argv);
3559
3560     if ((tmpgv = gv_fetchpv("0",TRUE, SVt_PV))) {
3561 #ifdef MACOS_TRADITIONAL
3562         /* $0 is not majick on a Mac */
3563         sv_setpv(GvSV(tmpgv),MacPerl_MPWFileName(PL_origfilename));
3564 #else
3565         sv_setpv(GvSV(tmpgv),PL_origfilename);
3566         magicname("0", "0", 1);
3567 #endif
3568     }
3569     if ((tmpgv = gv_fetchpv("\030",TRUE, SVt_PV))) {/* $^X */
3570 #ifdef HAS_PROCSELFEXE
3571         S_procself_val(aTHX_ GvSV(tmpgv), PL_origargv[0]);
3572 #else
3573 #ifdef OS2
3574         sv_setpv(GvSV(tmpgv), os2_execname(aTHX));
3575 #else
3576         sv_setpv(GvSV(tmpgv),PL_origargv[0]);
3577 #endif
3578 #endif
3579     }
3580     if ((PL_envgv = gv_fetchpv("ENV",TRUE, SVt_PVHV))) {
3581         HV *hv;
3582         GvMULTI_on(PL_envgv);
3583         hv = GvHVn(PL_envgv);
3584         hv_magic(hv, Nullgv, PERL_MAGIC_env);
3585 #ifdef USE_ENVIRON_ARRAY
3586         /* Note that if the supplied env parameter is actually a copy
3587            of the global environ then it may now point to free'd memory
3588            if the environment has been modified since. To avoid this
3589            problem we treat env==NULL as meaning 'use the default'
3590         */
3591         if (!env)
3592             env = environ;
3593         if (env != environ
3594 #  ifdef USE_ITHREADS
3595             && PL_curinterp == aTHX
3596 #  endif
3597            )
3598         {
3599             environ[0] = Nullch;
3600         }
3601         if (env)
3602           for (; *env; env++) {
3603             if (!(s = strchr(*env,'=')))
3604                 continue;
3605 #if defined(MSDOS)
3606             *s = '\0';
3607             (void)strupr(*env);
3608             *s = '=';
3609 #endif
3610             sv = newSVpv(s+1, 0);
3611             (void)hv_store(hv, *env, s - *env, sv, 0);
3612             if (env != environ)
3613                 mg_set(sv);
3614           }
3615 #endif /* USE_ENVIRON_ARRAY */
3616     }
3617     TAINT_NOT;
3618     if ((tmpgv = gv_fetchpv("$",TRUE, SVt_PV))) {
3619         SvREADONLY_off(GvSV(tmpgv));
3620         sv_setiv(GvSV(tmpgv), (IV)PerlProc_getpid());
3621         SvREADONLY_on(GvSV(tmpgv));
3622     }
3623
3624     /* touch @F array to prevent spurious warnings 20020415 MJD */
3625     if (PL_minus_a) {
3626       (void) get_av("main::F", TRUE | GV_ADDMULTI);
3627     }
3628     /* touch @- and @+ arrays to prevent spurious warnings 20020415 MJD */
3629     (void) get_av("main::-", TRUE | GV_ADDMULTI);
3630     (void) get_av("main::+", TRUE | GV_ADDMULTI);
3631 }
3632
3633 STATIC void
3634 S_init_perllib(pTHX)
3635 {
3636     char *s;
3637     if (!PL_tainting) {
3638 #ifndef VMS
3639         s = PerlEnv_getenv("PERL5LIB");
3640         if (s)
3641             incpush(s, TRUE, TRUE);
3642         else
3643             incpush(PerlEnv_getenv("PERLLIB"), FALSE, FALSE);
3644 #else /* VMS */
3645         /* Treat PERL5?LIB as a possible search list logical name -- the
3646          * "natural" VMS idiom for a Unix path string.  We allow each
3647          * element to be a set of |-separated directories for compatibility.
3648          */
3649         char buf[256];
3650         int idx = 0;
3651         if (my_trnlnm("PERL5LIB",buf,0))
3652             do { incpush(buf,TRUE,TRUE); } while (my_trnlnm("PERL5LIB",buf,++idx));
3653         else
3654             while (my_trnlnm("PERLLIB",buf,idx++)) incpush(buf,FALSE,FALSE);
3655 #endif /* VMS */
3656     }
3657
3658 /* Use the ~-expanded versions of APPLLIB (undocumented),
3659     ARCHLIB PRIVLIB SITEARCH SITELIB VENDORARCH and VENDORLIB
3660 */
3661 #ifdef APPLLIB_EXP
3662     incpush(APPLLIB_EXP, TRUE, TRUE);
3663 #endif
3664
3665 #ifdef ARCHLIB_EXP
3666     incpush(ARCHLIB_EXP, FALSE, FALSE);
3667 #endif
3668 #ifdef MACOS_TRADITIONAL
3669     {
3670         Stat_t tmpstatbuf;
3671         SV * privdir = NEWSV(55, 0);
3672         char * macperl = PerlEnv_getenv("MACPERL");
3673
3674         if (!macperl)
3675             macperl = "";
3676
3677         Perl_sv_setpvf(aTHX_ privdir, "%slib:", macperl);
3678         if (PerlLIO_stat(SvPVX(privdir), &tmpstatbuf) >= 0 && S_ISDIR(tmpstatbuf.st_mode))
3679             incpush(SvPVX(privdir), TRUE, FALSE);
3680         Perl_sv_setpvf(aTHX_ privdir, "%ssite_perl:", macperl);
3681         if (PerlLIO_stat(SvPVX(privdir), &tmpstatbuf) >= 0 && S_ISDIR(tmpstatbuf.st_mode))
3682             incpush(SvPVX(privdir), TRUE, FALSE);
3683
3684         SvREFCNT_dec(privdir);
3685     }
3686     if (!PL_tainting)
3687         incpush(":", FALSE, FALSE);
3688 #else
3689 #ifndef PRIVLIB_EXP
3690 #  define PRIVLIB_EXP "/usr/local/lib/perl5:/usr/local/lib/perl"
3691 #endif
3692 #if defined(WIN32)
3693     incpush(PRIVLIB_EXP, TRUE, FALSE);
3694 #else
3695     incpush(PRIVLIB_EXP, FALSE, FALSE);
3696 #endif
3697
3698 #ifdef SITEARCH_EXP
3699     /* sitearch is always relative to sitelib on Windows for
3700      * DLL-based path intuition to work correctly */
3701 #  if !defined(WIN32)
3702     incpush(SITEARCH_EXP, FALSE, FALSE);
3703 #  endif
3704 #endif
3705
3706 #ifdef SITELIB_EXP
3707 #  if defined(WIN32)
3708     incpush(SITELIB_EXP, TRUE, FALSE);  /* this picks up sitearch as well */
3709 #  else
3710     incpush(SITELIB_EXP, FALSE, FALSE);
3711 #  endif
3712 #endif
3713
3714 #ifdef SITELIB_STEM /* Search for version-specific dirs below here */
3715     incpush(SITELIB_STEM, FALSE, TRUE);
3716 #endif
3717
3718 #ifdef PERL_VENDORARCH_EXP
3719     /* vendorarch is always relative to vendorlib on Windows for
3720      * DLL-based path intuition to work correctly */
3721 #  if !defined(WIN32)
3722     incpush(PERL_VENDORARCH_EXP, FALSE, FALSE);
3723 #  endif
3724 #endif
3725
3726 #ifdef PERL_VENDORLIB_EXP
3727 #  if defined(WIN32)
3728     incpush(PERL_VENDORLIB_EXP, TRUE, FALSE);   /* this picks up vendorarch as well */
3729 #  else
3730     incpush(PERL_VENDORLIB_EXP, FALSE, FALSE);
3731 #  endif
3732 #endif
3733
3734 #ifdef PERL_VENDORLIB_STEM /* Search for version-specific dirs below here */
3735     incpush(PERL_VENDORLIB_STEM, FALSE, TRUE);
3736 #endif
3737
3738 #ifdef PERL_OTHERLIBDIRS
3739     incpush(PERL_OTHERLIBDIRS, TRUE, TRUE);
3740 #endif
3741
3742     if (!PL_tainting)
3743         incpush(".", FALSE, FALSE);
3744 #endif /* MACOS_TRADITIONAL */
3745 }
3746
3747 #if defined(DOSISH) || defined(EPOC)
3748 #    define PERLLIB_SEP ';'
3749 #else
3750 #  if defined(VMS)
3751 #    define PERLLIB_SEP '|'
3752 #  else
3753 #    if defined(MACOS_TRADITIONAL)
3754 #      define PERLLIB_SEP ','
3755 #    else
3756 #      define PERLLIB_SEP ':'
3757 #    endif
3758 #  endif
3759 #endif
3760 #ifndef PERLLIB_MANGLE
3761 #  define PERLLIB_MANGLE(s,n) (s)
3762 #endif
3763
3764 STATIC void
3765 S_incpush(pTHX_ char *p, int addsubdirs, int addoldvers)
3766 {
3767     SV *subdir = Nullsv;
3768
3769     if (!p || !*p)
3770         return;
3771
3772     if (addsubdirs || addoldvers) {
3773         subdir = sv_newmortal();
3774     }
3775
3776     /* Break at all separators */
3777     while (p && *p) {
3778         SV *libdir = NEWSV(55,0);
3779         char *s;
3780
3781         /* skip any consecutive separators */
3782         while ( *p == PERLLIB_SEP ) {
3783             /* Uncomment the next line for PATH semantics */
3784             /* av_push(GvAVn(PL_incgv), newSVpvn(".", 1)); */
3785             p++;
3786         }
3787
3788         if ( (s = strchr(p, PERLLIB_SEP)) != Nullch ) {
3789             sv_setpvn(libdir, PERLLIB_MANGLE(p, (STRLEN)(s - p)),
3790                       (STRLEN)(s - p));
3791             p = s + 1;
3792         }
3793         else {
3794             sv_setpv(libdir, PERLLIB_MANGLE(p, 0));
3795             p = Nullch; /* break out */
3796         }
3797 #ifdef MACOS_TRADITIONAL
3798         if (!strchr(SvPVX(libdir), ':')) {
3799             char buf[256];
3800
3801             sv_setpv(libdir, MacPerl_CanonDir(SvPVX(libdir), buf, 0));
3802         }
3803         if (SvPVX(libdir)[SvCUR(libdir)-1] != ':')
3804             sv_catpv(libdir, ":");
3805 #endif
3806
3807         /*
3808          * BEFORE pushing libdir onto @INC we may first push version- and
3809          * archname-specific sub-directories.
3810          */
3811         if (addsubdirs || addoldvers) {
3812 #ifdef PERL_INC_VERSION_LIST
3813             /* Configure terminates PERL_INC_VERSION_LIST with a NULL */
3814             const char *incverlist[] = { PERL_INC_VERSION_LIST };
3815             const char **incver;
3816 #endif
3817             Stat_t tmpstatbuf;
3818 #ifdef VMS
3819             char *unix;
3820             STRLEN len;
3821
3822             if ((unix = tounixspec_ts(SvPV(libdir,len),Nullch)) != Nullch) {
3823                 len = strlen(unix);
3824                 while (unix[len-1] == '/') len--;  /* Cosmetic */
3825                 sv_usepvn(libdir,unix,len);
3826             }
3827             else
3828                 PerlIO_printf(Perl_error_log,
3829                               "Failed to unixify @INC element \"%s\"\n",
3830                               SvPV(libdir,len));
3831 #endif
3832             if (addsubdirs) {
3833 #ifdef MACOS_TRADITIONAL
3834 #define PERL_AV_SUFFIX_FMT      ""
3835 #define PERL_ARCH_FMT           "%s:"
3836 #define PERL_ARCH_FMT_PATH      PERL_FS_VER_FMT PERL_AV_SUFFIX_FMT
3837 #else
3838 #define PERL_AV_SUFFIX_FMT      "/"
3839 #define PERL_ARCH_FMT           "/%s"
3840 #define PERL_ARCH_FMT_PATH      PERL_AV_SUFFIX_FMT PERL_FS_VER_FMT
3841 #endif
3842                 /* .../version/archname if -d .../version/archname */
3843                 Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_ARCH_FMT_PATH PERL_ARCH_FMT,
3844                                 libdir,
3845                                (int)PERL_REVISION, (int)PERL_VERSION,
3846                                (int)PERL_SUBVERSION, ARCHNAME);
3847                 if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
3848                       S_ISDIR(tmpstatbuf.st_mode))
3849                     av_push(GvAVn(PL_incgv), newSVsv(subdir));
3850
3851                 /* .../version if -d .../version */
3852                 Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_ARCH_FMT_PATH, libdir,
3853                                (int)PERL_REVISION, (int)PERL_VERSION,
3854                                (int)PERL_SUBVERSION);
3855                 if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
3856                       S_ISDIR(tmpstatbuf.st_mode))
3857                     av_push(GvAVn(PL_incgv), newSVsv(subdir));
3858
3859                 /* .../archname if -d .../archname */
3860                 Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_ARCH_FMT, libdir, ARCHNAME);
3861                 if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
3862                       S_ISDIR(tmpstatbuf.st_mode))
3863                     av_push(GvAVn(PL_incgv), newSVsv(subdir));
3864             }
3865
3866 #ifdef PERL_INC_VERSION_LIST
3867             if (addoldvers) {
3868                 for (incver = incverlist; *incver; incver++) {
3869                     /* .../xxx if -d .../xxx */
3870                     Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_ARCH_FMT, libdir, *incver);
3871                     if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
3872                           S_ISDIR(tmpstatbuf.st_mode))
3873                         av_push(GvAVn(PL_incgv), newSVsv(subdir));
3874                 }
3875             }
3876 #endif
3877         }
3878
3879         /* finally push this lib directory on the end of @INC */
3880         av_push(GvAVn(PL_incgv), libdir);
3881     }
3882 }
3883
3884 #ifdef USE_5005THREADS
3885 STATIC struct perl_thread *
3886 S_init_main_thread(pTHX)
3887 {
3888 #if !defined(PERL_IMPLICIT_CONTEXT)
3889     struct perl_thread *thr;
3890 #endif
3891     XPV *xpv;
3892
3893     Newz(53, thr, 1, struct perl_thread);
3894     PL_curcop = &PL_compiling;
3895     thr->interp = PERL_GET_INTERP;
3896     thr->cvcache = newHV();
3897     thr->threadsv = newAV();
3898     /* thr->threadsvp is set when find_threadsv is called */
3899     thr->specific = newAV();
3900     thr->flags = THRf_R_JOINABLE;
3901     MUTEX_INIT(&thr->mutex);
3902     /* Handcraft thrsv similarly to mess_sv */
3903     New(53, PL_thrsv, 1, SV);
3904     Newz(53, xpv, 1, XPV);
3905     SvFLAGS(PL_thrsv) = SVt_PV;
3906     SvANY(PL_thrsv) = (void*)xpv;
3907     SvREFCNT(PL_thrsv) = 1 << 30;       /* practically infinite */
3908     SvPVX(PL_thrsv) = (char*)thr;
3909     SvCUR_set(PL_thrsv, sizeof(thr));
3910     SvLEN_set(PL_thrsv, sizeof(thr));
3911     *SvEND(PL_thrsv) = '\0';    /* in the trailing_nul field */
3912     thr->oursv = PL_thrsv;
3913     PL_chopset = " \n-";
3914     PL_dumpindent = 4;
3915
3916     MUTEX_LOCK(&PL_threads_mutex);
3917     PL_nthreads++;
3918     thr->tid = 0;
3919     thr->next = thr;
3920     thr->prev = thr;
3921     thr->thr_done = 0;
3922     MUTEX_UNLOCK(&PL_threads_mutex);
3923
3924 #ifdef HAVE_THREAD_INTERN
3925     Perl_init_thread_intern(thr);
3926 #endif
3927
3928 #ifdef SET_THREAD_SELF
3929     SET_THREAD_SELF(thr);
3930 #else
3931     thr->self = pthread_self();
3932 #endif /* SET_THREAD_SELF */
3933     PERL_SET_THX(thr);
3934
3935     /*
3936      * These must come after the thread self setting
3937      * because sv_setpvn does SvTAINT and the taint
3938      * fields thread selfness being set.
3939      */
3940     PL_toptarget = NEWSV(0,0);
3941     sv_upgrade(PL_toptarget, SVt_PVFM);
3942     sv_setpvn(PL_toptarget, "", 0);
3943     PL_bodytarget = NEWSV(0,0);
3944     sv_upgrade(PL_bodytarget, SVt_PVFM);
3945     sv_setpvn(PL_bodytarget, "", 0);
3946     PL_formtarget = PL_bodytarget;
3947     thr->errsv = newSVpvn("", 0);
3948     (void) find_threadsv("@");  /* Ensure $@ is initialised early */
3949
3950     PL_maxscream = -1;
3951     PL_peepp = MEMBER_TO_FPTR(Perl_peep);
3952     PL_regcompp = MEMBER_TO_FPTR(Perl_pregcomp);
3953     PL_regexecp = MEMBER_TO_FPTR(Perl_regexec_flags);
3954     PL_regint_start = MEMBER_TO_FPTR(Perl_re_intuit_start);
3955     PL_regint_string = MEMBER_TO_FPTR(Perl_re_intuit_string);
3956     PL_regfree = MEMBER_TO_FPTR(Perl_pregfree);
3957     PL_regindent = 0;
3958     PL_reginterp_cnt = 0;
3959
3960     return thr;
3961 }
3962 #endif /* USE_5005THREADS */
3963
3964 void
3965 Perl_call_list(pTHX_ I32 oldscope, AV *paramList)
3966 {
3967     SV *atsv;
3968     line_t oldline = CopLINE(PL_curcop);
3969     CV *cv;
3970     STRLEN len;
3971     int ret;
3972     dJMPENV;
3973
3974     while (AvFILL(paramList) >= 0) {
3975         cv = (CV*)av_shift(paramList);
3976         if (PL_savebegin && (paramList == PL_beginav)) {
3977                 /* save PL_beginav for compiler */
3978             if (! PL_beginav_save)
3979                 PL_beginav_save = newAV();
3980             av_push(PL_beginav_save, (SV*)cv);
3981         } else {
3982             SAVEFREESV(cv);
3983         }
3984 #ifdef PERL_FLEXIBLE_EXCEPTIONS
3985         CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_vcall_list_body), cv);
3986 #else
3987         JMPENV_PUSH(ret);
3988 #endif
3989         switch (ret) {
3990         case 0:
3991 #ifndef PERL_FLEXIBLE_EXCEPTIONS
3992             call_list_body(cv);
3993 #endif
3994             atsv = ERRSV;
3995             (void)SvPV(atsv, len);
3996             if (len) {
3997                 STRLEN n_a;
3998                 PL_curcop = &PL_compiling;
3999                 CopLINE_set(PL_curcop, oldline);
4000                 if (paramList == PL_beginav)
4001                     sv_catpv(atsv, "BEGIN failed--compilation aborted");
4002                 else
4003                     Perl_sv_catpvf(aTHX_ atsv,
4004                                    "%s failed--call queue aborted",
4005                                    paramList == PL_checkav ? "CHECK"
4006                                    : paramList == PL_initav ? "INIT"
4007                                    : "END");
4008                 while (PL_scopestack_ix > oldscope)
4009                     LEAVE;
4010                 JMPENV_POP;
4011                 Perl_croak(aTHX_ "%s", SvPVx(atsv, n_a));
4012             }
4013             break;
4014         case 1:
4015             STATUS_ALL_FAILURE;
4016             /* FALL THROUGH */
4017         case 2:
4018             /* my_exit() was called */
4019             while (PL_scopestack_ix > oldscope)
4020                 LEAVE;
4021             FREETMPS;
4022             PL_curstash = PL_defstash;
4023             PL_curcop = &PL_compiling;
4024             CopLINE_set(PL_curcop, oldline);
4025             JMPENV_POP;
4026             if (PL_statusvalue && !(PL_exit_flags & PERL_EXIT_EXPECTED)) {
4027                 if (paramList == PL_beginav)
4028                     Perl_croak(aTHX_ "BEGIN failed--compilation aborted");
4029                 else
4030                     Perl_croak(aTHX_ "%s failed--call queue aborted",
4031                                paramList == PL_checkav ? "CHECK"
4032                                : paramList == PL_initav ? "INIT"
4033                                : "END");
4034             }
4035             my_exit_jump();
4036             /* NOTREACHED */
4037         case 3:
4038             if (PL_restartop) {
4039                 PL_curcop = &PL_compiling;
4040                 CopLINE_set(PL_curcop, oldline);
4041                 JMPENV_JUMP(3);
4042             }
4043             PerlIO_printf(Perl_error_log, "panic: restartop\n");
4044             FREETMPS;
4045             break;
4046         }
4047         JMPENV_POP;
4048     }
4049 }
4050
4051 #ifdef PERL_FLEXIBLE_EXCEPTIONS
4052 STATIC void *
4053 S_vcall_list_body(pTHX_ va_list args)
4054 {
4055     CV *cv = va_arg(args, CV*);
4056     return call_list_body(cv);
4057 }
4058 #endif
4059
4060 STATIC void *
4061 S_call_list_body(pTHX_ CV *cv)
4062 {
4063     PUSHMARK(PL_stack_sp);
4064     call_sv((SV*)cv, G_EVAL|G_DISCARD);
4065     return NULL;
4066 }
4067
4068 void
4069 Perl_my_exit(pTHX_ U32 status)
4070 {
4071     DEBUG_S(PerlIO_printf(Perl_debug_log, "my_exit: thread %p, status %lu\n",
4072                           thr, (unsigned long) status));
4073     switch (status) {
4074     case 0:
4075         STATUS_ALL_SUCCESS;
4076         break;
4077     case 1:
4078         STATUS_ALL_FAILURE;
4079         break;
4080     default:
4081         STATUS_NATIVE_SET(status);
4082         break;
4083     }
4084     my_exit_jump();
4085 }
4086
4087 void
4088 Perl_my_failure_exit(pTHX)
4089 {
4090 #ifdef VMS
4091     if (vaxc$errno & 1) {
4092         if (STATUS_NATIVE & 1)          /* fortuitiously includes "-1" */
4093             STATUS_NATIVE_SET(44);
4094     }
4095     else {
4096         if (!vaxc$errno && errno)       /* unlikely */
4097             STATUS_NATIVE_SET(44);
4098         else
4099             STATUS_NATIVE_SET(vaxc$errno);
4100     }
4101 #else
4102     int exitstatus;
4103     if (errno & 255)
4104         STATUS_POSIX_SET(errno);
4105     else {
4106         exitstatus = STATUS_POSIX >> 8;
4107         if (exitstatus & 255)
4108             STATUS_POSIX_SET(exitstatus);
4109         else
4110             STATUS_POSIX_SET(255);
4111     }
4112 #endif
4113     my_exit_jump();
4114 }
4115
4116 STATIC void
4117 S_my_exit_jump(pTHX)
4118 {
4119     register PERL_CONTEXT *cx;
4120     I32 gimme;
4121     SV **newsp;
4122
4123     if (PL_e_script) {
4124         SvREFCNT_dec(PL_e_script);
4125         PL_e_script = Nullsv;
4126     }
4127
4128     POPSTACK_TO(PL_mainstack);
4129     if (cxstack_ix >= 0) {
4130         if (cxstack_ix > 0)
4131             dounwind(0);
4132         POPBLOCK(cx,PL_curpm);
4133         LEAVE;
4134     }
4135
4136     JMPENV_JUMP(2);
4137 }
4138
4139 static I32
4140 read_e_script(pTHX_ int idx, SV *buf_sv, int maxlen)
4141 {
4142     char *p, *nl;
4143     p  = SvPVX(PL_e_script);
4144     nl = strchr(p, '\n');
4145     nl = (nl) ? nl+1 : SvEND(PL_e_script);
4146     if (nl-p == 0) {
4147         filter_del(read_e_script);
4148         return 0;
4149     }
4150     sv_catpvn(buf_sv, p, nl-p);
4151     sv_chop(PL_e_script, nl);
4152     return 1;
4153 }