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