perl.c

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