perl.c

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