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,24);
 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_BITS
 989                 sv_catpv(PL_Sv," USE_64_BITS");
 990 #  endif
 991 #  ifdef USE_LONG_DOUBLE
 992                 sv_catpv(PL_Sv," USE_LONG_DOUBLE");
 993 #  endif
 994 #  ifdef USE_LARGE_FILES
 995                 sv_catpv(PL_Sv," USE_LARGE_FILES");
 996 #  endif
 997 #  ifdef USE_SOCKS
 998                 sv_catpv(PL_Sv," USE_SOCKS");
 999 #  endif
1000 #  ifdef PERL_OBJECT
1001                 sv_catpv(PL_Sv," PERL_OBJECT");
1002 #  endif
1003 #  ifdef PERL_IMPLICIT_CONTEXT
1004                 sv_catpv(PL_Sv," PERL_IMPLICIT_CONTEXT");
1005 #  endif
1006 #  ifdef PERL_IMPLICIT_SYS
1007                 sv_catpv(PL_Sv," PERL_IMPLICIT_SYS");
1008 #  endif
1009                 sv_catpv(PL_Sv,"\\n\",");
1010
1011 #if defined(LOCAL_PATCH_COUNT)
1012                 if (LOCAL_PATCH_COUNT > 0) {
1013                     int i;
1014                     sv_catpv(PL_Sv,"\"  Locally applied patches:\\n\",");
1015                     for (i = 1; i <= LOCAL_PATCH_COUNT; i++) {
1016                         if (PL_localpatches[i])
1017                             Perl_sv_catpvf(aTHX_ PL_Sv,"q\"  \t%s\n\",",PL_localpatches[i]);
1018                     }
1019                 }
1020 #endif
1021                 Perl_sv_catpvf(aTHX_ PL_Sv,"\"  Built under %s\\n\"",OSNAME);
1022 #ifdef __DATE__
1023 #  ifdef __TIME__
1024                 Perl_sv_catpvf(aTHX_ PL_Sv,",\"  Compiled at %s %s\\n\"",__DATE__,__TIME__);
1025 #  else
1026                 Perl_sv_catpvf(aTHX_ PL_Sv,",\"  Compiled on %s\\n\"",__DATE__);
1027 #  endif
1028 #endif
1029                 sv_catpv(PL_Sv, "; \
1030 $\"=\"\\n    \"; \
1031 @env = map { \"$_=\\\"$ENV{$_}\\\"\" } sort grep {/^PERL/} keys %ENV; \
1032 print \"  \\%ENV:\\n    @env\\n\" if @env; \
1033 print \"  \\@INC:\\n    @INC\\n\";");
1034             }
1035             else {
1036                 PL_Sv = newSVpv("config_vars(qw(",0);
1037                 sv_catpv(PL_Sv, ++s);
1038                 sv_catpv(PL_Sv, "))");
1039                 s += strlen(s);
1040             }
1041             av_push(PL_preambleav, PL_Sv);
1042             scriptname = BIT_BUCKET;    /* don't look for script or read stdin */
1043             goto reswitch;
1044         case 'x':
1045             PL_doextract = TRUE;
1046             s++;
1047             if (*s)
1048                 cddir = s;
1049             break;
1050         case 0:
1051             break;
1052         case '-':
1053             if (!*++s || isSPACE(*s)) {
1054                 argc--,argv++;
1055                 goto switch_end;
1056             }
1057             /* catch use of gnu style long options */
1058             if (strEQ(s, "version")) {
1059                 s = "v";
1060                 goto reswitch;
1061             }
1062             if (strEQ(s, "help")) {
1063                 s = "h";
1064                 goto reswitch;
1065             }
1066             s--;
1067             /* FALL THROUGH */
1068         default:
1069             Perl_croak(aTHX_ "Unrecognized switch: -%s  (-h will show valid options)",s);
1070         }
1071     }
1072   switch_end:
1073
1074     if (
1075 #ifndef SECURE_INTERNAL_GETENV
1076         !PL_tainting &&
1077 #endif
1078         (s = PerlEnv_getenv("PERL5OPT")))
1079     {
1080         while (isSPACE(*s))
1081             s++;
1082         if (*s == '-' && *(s+1) == 'T')
1083             PL_tainting = TRUE;
1084         else {
1085             while (s && *s) {
1086                 while (isSPACE(*s))
1087                     s++;
1088                 if (*s == '-') {
1089                     s++;
1090                     if (isSPACE(*s))
1091                         continue;
1092                 }
1093                 if (!*s)
1094                     break;
1095                 if (!strchr("DIMUdmw", *s))
1096                     Perl_croak(aTHX_ "Illegal switch in PERL5OPT: -%c", *s);
1097                 s = moreswitches(s);
1098             }
1099         }
1100     }
1101
1102     if (!scriptname)
1103         scriptname = argv[0];
1104     if (PL_e_script) {
1105         argc++,argv--;
1106         scriptname = BIT_BUCKET;        /* don't look for script or read stdin */
1107     }
1108     else if (scriptname == Nullch) {
1109 #ifdef MSDOS
1110         if ( PerlLIO_isatty(PerlIO_fileno(PerlIO_stdin())) )
1111             moreswitches("h");
1112 #endif
1113         scriptname = "-";
1114     }
1115
1116     init_perllib();
1117
1118     open_script(scriptname,dosearch,sv,&fdscript);
1119
1120     validate_suid(validarg, scriptname,fdscript);
1121
1122 #if defined(SIGCHLD) || defined(SIGCLD)
1123     {
1124 #ifndef SIGCHLD
1125 #  define SIGCHLD SIGCLD
1126 #endif
1127         Sighandler_t sigstate = rsignal_state(SIGCHLD);
1128         if (sigstate == SIG_IGN) {
1129             if (ckWARN(WARN_SIGNAL))
1130                 Perl_warner(aTHX_ WARN_SIGNAL,
1131                             "Can't ignore signal CHLD, forcing to default");
1132             (void)rsignal(SIGCHLD, (Sighandler_t)SIG_DFL);
1133         }
1134     }
1135 #endif
1136
1137     if (PL_doextract) {
1138         find_beginning();
1139         if (cddir && PerlDir_chdir(cddir) < 0)
1140             Perl_croak(aTHX_ "Can't chdir to %s",cddir);
1141
1142     }
1143
1144     PL_main_cv = PL_compcv = (CV*)NEWSV(1104,0);
1145     sv_upgrade((SV *)PL_compcv, SVt_PVCV);
1146     CvUNIQUE_on(PL_compcv);
1147
1148     PL_comppad = newAV();
1149     av_push(PL_comppad, Nullsv);
1150     PL_curpad = AvARRAY(PL_comppad);
1151     PL_comppad_name = newAV();
1152     PL_comppad_name_fill = 0;
1153     PL_min_intro_pending = 0;
1154     PL_padix = 0;
1155 #ifdef USE_THREADS
1156     av_store(PL_comppad_name, 0, newSVpvn("@_", 2));
1157     PL_curpad[0] = (SV*)newAV();
1158     SvPADMY_on(PL_curpad[0]);   /* XXX Needed? */
1159     CvOWNER(PL_compcv) = 0;
1160     New(666, CvMUTEXP(PL_compcv), 1, perl_mutex);
1161     MUTEX_INIT(CvMUTEXP(PL_compcv));
1162 #endif /* USE_THREADS */
1163
1164     comppadlist = newAV();
1165     AvREAL_off(comppadlist);
1166     av_store(comppadlist, 0, (SV*)PL_comppad_name);
1167     av_store(comppadlist, 1, (SV*)PL_comppad);
1168     CvPADLIST(PL_compcv) = comppadlist;
1169
1170     boot_core_UNIVERSAL();
1171 #ifndef PERL_MICRO
1172     boot_core_xsutils();
1173 #endif
1174
1175     if (xsinit)
1176         (*xsinit)(aTHXo);       /* in case linked C routines want magical variables */
1177 #if defined(VMS) || defined(WIN32) || defined(DJGPP)
1178     init_os_extras();
1179 #endif
1180
1181 #ifdef USE_SOCKS
1182     SOCKSinit(argv[0]);
1183 #endif
1184
1185     init_predump_symbols();
1186     /* init_postdump_symbols not currently designed to be called */
1187     /* more than once (ENV isn't cleared first, for example)     */
1188     /* But running with -u leaves %ENV & @ARGV undefined!    XXX */
1189     if (!PL_do_undump)
1190         init_postdump_symbols(argc,argv,env);
1191
1192     init_lexer();
1193
1194     /* now parse the script */
1195
1196     SETERRNO(0,SS$_NORMAL);
1197     PL_error_count = 0;
1198     if (yyparse() || PL_error_count) {
1199         if (PL_minus_c)
1200             Perl_croak(aTHX_ "%s had compilation errors.\n", PL_origfilename);
1201         else {
1202             Perl_croak(aTHX_ "Execution of %s aborted due to compilation errors.\n",
1203                        PL_origfilename);
1204         }
1205     }
1206     CopLINE_set(PL_curcop, 0);
1207     PL_curstash = PL_defstash;
1208     PL_preprocess = FALSE;
1209     if (PL_e_script) {
1210         SvREFCNT_dec(PL_e_script);
1211         PL_e_script = Nullsv;
1212     }
1213
1214     /* now that script is parsed, we can modify record separator */
1215     SvREFCNT_dec(PL_rs);
1216     PL_rs = SvREFCNT_inc(PL_nrs);
1217     sv_setsv(get_sv("/", TRUE), PL_rs);
1218     if (PL_do_undump)
1219         my_unexec();
1220
1221     if (isWARN_ONCE) {
1222         SAVECOPFILE(PL_curcop);
1223         SAVECOPLINE(PL_curcop);
1224         gv_check(PL_defstash);
1225     }
1226
1227     LEAVE;
1228     FREETMPS;
1229
1230 #ifdef MYMALLOC
1231     if ((s=PerlEnv_getenv("PERL_DEBUG_MSTATS")) && atoi(s) >= 2)
1232         dump_mstats("after compilation:");
1233 #endif
1234
1235     ENTER;
1236     PL_restartop = 0;
1237     return NULL;
1238 }
1239
1240 /*
1241 =for apidoc perl_run
1242
1243 Tells a Perl interpreter to run.  See L<perlembed>.
1244
1245 =cut
1246 */
1247
1248 int
1249 perl_run(pTHXx)
1250 {
1251     dTHR;
1252     I32 oldscope;
1253     int ret = 0;
1254     dJMPENV;
1255 #ifdef USE_THREADS
1256     dTHX;
1257 #endif
1258
1259     oldscope = PL_scopestack_ix;
1260
1261 #ifdef PERL_FLEXIBLE_EXCEPTIONS
1262  redo_body:
1263     CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_vrun_body), oldscope);
1264 #else
1265     JMPENV_PUSH(ret);
1266 #endif
1267     switch (ret) {
1268     case 1:
1269         cxstack_ix = -1;                /* start context stack again */
1270         goto redo_body;
1271     case 0:                             /* normal completion */
1272 #ifndef PERL_FLEXIBLE_EXCEPTIONS
1273  redo_body:
1274         run_body(oldscope);
1275 #endif
1276         /* FALL THROUGH */
1277     case 2:                             /* my_exit() */
1278         while (PL_scopestack_ix > oldscope)
1279             LEAVE;
1280         FREETMPS;
1281         PL_curstash = PL_defstash;
1282         if (PL_endav && !PL_minus_c)
1283             call_list(oldscope, PL_endav);
1284 #ifdef MYMALLOC
1285         if (PerlEnv_getenv("PERL_DEBUG_MSTATS"))
1286             dump_mstats("after execution:  ");
1287 #endif
1288         ret = STATUS_NATIVE_EXPORT;
1289         break;
1290     case 3:
1291         if (PL_restartop) {
1292             POPSTACK_TO(PL_mainstack);
1293             goto redo_body;
1294         }
1295         PerlIO_printf(Perl_error_log, "panic: restartop\n");
1296         FREETMPS;
1297         ret = 1;
1298         break;
1299     }
1300
1301     JMPENV_POP;
1302     return ret;
1303 }
1304
1305 #ifdef PERL_FLEXIBLE_EXCEPTIONS
1306 STATIC void *
1307 S_vrun_body(pTHX_ va_list args)
1308 {
1309     I32 oldscope = va_arg(args, I32);
1310
1311     return run_body(oldscope);
1312 }
1313 #endif
1314
1315
1316 STATIC void *
1317 S_run_body(pTHX_ I32 oldscope)
1318 {
1319     dTHR;
1320
1321     DEBUG_r(PerlIO_printf(Perl_debug_log, "%s $` $& $' support.\n",
1322                     PL_sawampersand ? "Enabling" : "Omitting"));
1323
1324     if (!PL_restartop) {
1325         DEBUG_x(dump_all());
1326         DEBUG(PerlIO_printf(Perl_debug_log, "\nEXECUTING...\n\n"));
1327         DEBUG_S(PerlIO_printf(Perl_debug_log, "main thread is 0x%"UVxf"\n",
1328                               PTR2UV(thr)));
1329
1330         if (PL_minus_c) {
1331             PerlIO_printf(Perl_error_log, "%s syntax OK\n", PL_origfilename);
1332             my_exit(0);
1333         }
1334         if (PERLDB_SINGLE && PL_DBsingle)
1335             sv_setiv(PL_DBsingle, 1);
1336         if (PL_initav)
1337             call_list(oldscope, PL_initav);
1338     }
1339
1340     /* do it */
1341
1342     if (PL_restartop) {
1343         PL_op = PL_restartop;
1344         PL_restartop = 0;
1345         CALLRUNOPS(aTHX);
1346     }
1347     else if (PL_main_start) {
1348         CvDEPTH(PL_main_cv) = 1;
1349         PL_op = PL_main_start;
1350         CALLRUNOPS(aTHX);
1351     }
1352
1353     my_exit(0);
1354     /* NOTREACHED */
1355     return NULL;
1356 }
1357
1358 /*
1359 =for apidoc p||get_sv
1360
1361 Returns the SV of the specified Perl scalar.  If C<create> is set and the
1362 Perl variable does not exist then it will be created.  If C<create> is not
1363 set and the variable does not exist then NULL is returned.
1364
1365 =cut
1366 */
1367
1368 SV*
1369 Perl_get_sv(pTHX_ const char *name, I32 create)
1370 {
1371     GV *gv;
1372 #ifdef USE_THREADS
1373     if (name[1] == '\0' && !isALPHA(name[0])) {
1374         PADOFFSET tmp = find_threadsv(name);
1375         if (tmp != NOT_IN_PAD) {
1376             dTHR;
1377             return THREADSV(tmp);
1378         }
1379     }
1380 #endif /* USE_THREADS */
1381     gv = gv_fetchpv(name, create, SVt_PV);
1382     if (gv)
1383         return GvSV(gv);
1384     return Nullsv;
1385 }
1386
1387 /*
1388 =for apidoc p||get_av
1389
1390 Returns the AV of the specified Perl array.  If C<create> is set and the
1391 Perl variable does not exist then it will be created.  If C<create> is not
1392 set and the variable does not exist then NULL is returned.
1393
1394 =cut
1395 */
1396
1397 AV*
1398 Perl_get_av(pTHX_ const char *name, I32 create)
1399 {
1400     GV* gv = gv_fetchpv(name, create, SVt_PVAV);
1401     if (create)
1402         return GvAVn(gv);
1403     if (gv)
1404         return GvAV(gv);
1405     return Nullav;
1406 }
1407
1408 /*
1409 =for apidoc p||get_hv
1410
1411 Returns the HV of the specified Perl hash.  If C<create> is set and the
1412 Perl variable does not exist then it will be created.  If C<create> is not
1413 set and the variable does not exist then NULL is returned.
1414
1415 =cut
1416 */
1417
1418 HV*
1419 Perl_get_hv(pTHX_ const char *name, I32 create)
1420 {
1421     GV* gv = gv_fetchpv(name, create, SVt_PVHV);
1422     if (create)
1423         return GvHVn(gv);
1424     if (gv)
1425         return GvHV(gv);
1426     return Nullhv;
1427 }
1428
1429 /*
1430 =for apidoc p||get_cv
1431
1432 Returns the CV of the specified Perl subroutine.  If C<create> is set and
1433 the Perl subroutine does not exist then it will be declared (which has the
1434 same effect as saying C<sub name;>).  If C<create> is not set and the
1435 subroutine does not exist then NULL is returned.
1436
1437 =cut
1438 */
1439
1440 CV*
1441 Perl_get_cv(pTHX_ const char *name, I32 create)
1442 {
1443     GV* gv = gv_fetchpv(name, create, SVt_PVCV);
1444     /* XXX unsafe for threads if eval_owner isn't held */
1445     /* XXX this is probably not what they think they're getting.
1446      * It has the same effect as "sub name;", i.e. just a forward
1447      * declaration! */
1448     if (create && !GvCVu(gv))
1449         return newSUB(start_subparse(FALSE, 0),
1450                       newSVOP(OP_CONST, 0, newSVpv(name,0)),
1451                       Nullop,
1452                       Nullop);
1453     if (gv)
1454         return GvCVu(gv);
1455     return Nullcv;
1456 }
1457
1458 /* Be sure to refetch the stack pointer after calling these routines. */
1459
1460 /*
1461 =for apidoc p||call_argv
1462
1463 Performs a callback to the specified Perl sub.  See L<perlcall>.
1464
1465 =cut
1466 */
1467
1468 I32
1469 Perl_call_argv(pTHX_ const char *sub_name, I32 flags, register char **argv)
1470
1471                         /* See G_* flags in cop.h */
1472                         /* null terminated arg list */
1473 {
1474     dSP;
1475
1476     PUSHMARK(SP);
1477     if (argv) {
1478         while (*argv) {
1479             XPUSHs(sv_2mortal(newSVpv(*argv,0)));
1480             argv++;
1481         }
1482         PUTBACK;
1483     }
1484     return call_pv(sub_name, flags);
1485 }
1486
1487 /*
1488 =for apidoc p||call_pv
1489
1490 Performs a callback to the specified Perl sub.  See L<perlcall>.
1491
1492 =cut
1493 */
1494
1495 I32
1496 Perl_call_pv(pTHX_ const char *sub_name, I32 flags)
1497                         /* name of the subroutine */
1498                         /* See G_* flags in cop.h */
1499 {
1500     return call_sv((SV*)get_cv(sub_name, TRUE), flags);
1501 }
1502
1503 /*
1504 =for apidoc p||call_method
1505
1506 Performs a callback to the specified Perl method.  The blessed object must
1507 be on the stack.  See L<perlcall>.
1508
1509 =cut
1510 */
1511
1512 I32
1513 Perl_call_method(pTHX_ const char *methname, I32 flags)
1514                         /* name of the subroutine */
1515                         /* See G_* flags in cop.h */
1516 {
1517     dSP;
1518     OP myop;
1519     if (!PL_op) {
1520         Zero(&myop, 1, OP);
1521         PL_op = &myop;
1522     }
1523     XPUSHs(sv_2mortal(newSVpv(methname,0)));
1524     PUTBACK;
1525     pp_method();
1526     if (PL_op == &myop)
1527         PL_op = Nullop;
1528     return call_sv(*PL_stack_sp--, flags);
1529 }
1530
1531 /* May be called with any of a CV, a GV, or an SV containing the name. */
1532 /*
1533 =for apidoc p||call_sv
1534
1535 Performs a callback to the Perl sub whose name is in the SV.  See
1536 L<perlcall>.
1537
1538 =cut
1539 */
1540
1541 I32
1542 Perl_call_sv(pTHX_ SV *sv, I32 flags)
1543
1544                         /* See G_* flags in cop.h */
1545 {
1546     dSP;
1547     LOGOP myop;         /* fake syntax tree node */
1548     I32 oldmark;
1549     I32 retval;
1550     I32 oldscope;
1551     bool oldcatch = CATCH_GET;
1552     int ret;
1553     OP* oldop = PL_op;
1554     dJMPENV;
1555
1556     if (flags & G_DISCARD) {
1557         ENTER;
1558         SAVETMPS;
1559     }
1560
1561     Zero(&myop, 1, LOGOP);
1562     myop.op_next = Nullop;
1563     if (!(flags & G_NOARGS))
1564         myop.op_flags |= OPf_STACKED;
1565     myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
1566                       (flags & G_ARRAY) ? OPf_WANT_LIST :
1567                       OPf_WANT_SCALAR);
1568     SAVEOP();
1569     PL_op = (OP*)&myop;
1570
1571     EXTEND(PL_stack_sp, 1);
1572     *++PL_stack_sp = sv;
1573     oldmark = TOPMARK;
1574     oldscope = PL_scopestack_ix;
1575
1576     if (PERLDB_SUB && PL_curstash != PL_debstash
1577            /* Handle first BEGIN of -d. */
1578           && (PL_DBcv || (PL_DBcv = GvCV(PL_DBsub)))
1579            /* Try harder, since this may have been a sighandler, thus
1580             * curstash may be meaningless. */
1581           && (SvTYPE(sv) != SVt_PVCV || CvSTASH((CV*)sv) != PL_debstash)
1582           && !(flags & G_NODEBUG))
1583         PL_op->op_private |= OPpENTERSUB_DB;
1584
1585     if (!(flags & G_EVAL)) {
1586         CATCH_SET(TRUE);
1587         call_body((OP*)&myop, FALSE);
1588         retval = PL_stack_sp - (PL_stack_base + oldmark);
1589         CATCH_SET(oldcatch);
1590     }
1591     else {
1592         cLOGOP->op_other = PL_op;
1593         PL_markstack_ptr--;
1594         /* we're trying to emulate pp_entertry() here */
1595         {
1596             register PERL_CONTEXT *cx;
1597             I32 gimme = GIMME_V;
1598
1599             ENTER;
1600             SAVETMPS;
1601
1602             push_return(PL_op->op_next);
1603             PUSHBLOCK(cx, CXt_EVAL, PL_stack_sp);
1604             PUSHEVAL(cx, 0, 0);
1605             PL_eval_root = PL_op;             /* Only needed so that goto works right. */
1606
1607             PL_in_eval = EVAL_INEVAL;
1608             if (flags & G_KEEPERR)
1609                 PL_in_eval |= EVAL_KEEPERR;
1610             else
1611                 sv_setpv(ERRSV,"");
1612         }
1613         PL_markstack_ptr++;
1614
1615 #ifdef PERL_FLEXIBLE_EXCEPTIONS
1616  redo_body:
1617         CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_vcall_body),
1618                     (OP*)&myop, FALSE);
1619 #else
1620         JMPENV_PUSH(ret);
1621 #endif
1622         switch (ret) {
1623         case 0:
1624 #ifndef PERL_FLEXIBLE_EXCEPTIONS
1625  redo_body:
1626             call_body((OP*)&myop, FALSE);
1627 #endif
1628             retval = PL_stack_sp - (PL_stack_base + oldmark);
1629             if (!(flags & G_KEEPERR))
1630                 sv_setpv(ERRSV,"");
1631             break;
1632         case 1:
1633             STATUS_ALL_FAILURE;
1634             /* FALL THROUGH */
1635         case 2:
1636             /* my_exit() was called */
1637             PL_curstash = PL_defstash;
1638             FREETMPS;
1639             JMPENV_POP;
1640             if (PL_statusvalue && !(PL_exit_flags & PERL_EXIT_EXPECTED))
1641                 Perl_croak(aTHX_ "Callback called exit");
1642             my_exit_jump();
1643             /* NOTREACHED */
1644         case 3:
1645             if (PL_restartop) {
1646                 PL_op = PL_restartop;
1647                 PL_restartop = 0;
1648                 goto redo_body;
1649             }
1650             PL_stack_sp = PL_stack_base + oldmark;
1651             if (flags & G_ARRAY)
1652                 retval = 0;
1653             else {
1654                 retval = 1;
1655                 *++PL_stack_sp = &PL_sv_undef;
1656             }
1657             break;
1658         }
1659
1660         if (PL_scopestack_ix > oldscope) {
1661             SV **newsp;
1662             PMOP *newpm;
1663             I32 gimme;
1664             register PERL_CONTEXT *cx;
1665             I32 optype;
1666
1667             POPBLOCK(cx,newpm);
1668             POPEVAL(cx);
1669             pop_return();
1670             PL_curpm = newpm;
1671             LEAVE;
1672         }
1673         JMPENV_POP;
1674     }
1675
1676     if (flags & G_DISCARD) {
1677         PL_stack_sp = PL_stack_base + oldmark;
1678         retval = 0;
1679         FREETMPS;
1680         LEAVE;
1681     }
1682     PL_op = oldop;
1683     return retval;
1684 }
1685
1686 #ifdef PERL_FLEXIBLE_EXCEPTIONS
1687 STATIC void *
1688 S_vcall_body(pTHX_ va_list args)
1689 {
1690     OP *myop = va_arg(args, OP*);
1691     int is_eval = va_arg(args, int);
1692
1693     call_body(myop, is_eval);
1694     return NULL;
1695 }
1696 #endif
1697
1698 STATIC void
1699 S_call_body(pTHX_ OP *myop, int is_eval)
1700 {
1701     dTHR;
1702
1703     if (PL_op == myop) {
1704         if (is_eval)
1705             PL_op = Perl_pp_entereval(aTHX);
1706         else
1707             PL_op = Perl_pp_entersub(aTHX);
1708     }
1709     if (PL_op)
1710         CALLRUNOPS(aTHX);
1711 }
1712
1713 /* Eval a string. The G_EVAL flag is always assumed. */
1714
1715 /*
1716 =for apidoc p||eval_sv
1717
1718 Tells Perl to C<eval> the string in the SV.
1719
1720 =cut
1721 */
1722
1723 I32
1724 Perl_eval_sv(pTHX_ SV *sv, I32 flags)
1725
1726                         /* See G_* flags in cop.h */
1727 {
1728     dSP;
1729     UNOP myop;          /* fake syntax tree node */
1730     I32 oldmark = SP - PL_stack_base;
1731     I32 retval;
1732     I32 oldscope;
1733     int ret;
1734     OP* oldop = PL_op;
1735     dJMPENV;
1736
1737     if (flags & G_DISCARD) {
1738         ENTER;
1739         SAVETMPS;
1740     }
1741
1742     SAVEOP();
1743     PL_op = (OP*)&myop;
1744     Zero(PL_op, 1, UNOP);
1745     EXTEND(PL_stack_sp, 1);
1746     *++PL_stack_sp = sv;
1747     oldscope = PL_scopestack_ix;
1748
1749     if (!(flags & G_NOARGS))
1750         myop.op_flags = OPf_STACKED;
1751     myop.op_next = Nullop;
1752     myop.op_type = OP_ENTEREVAL;
1753     myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
1754                       (flags & G_ARRAY) ? OPf_WANT_LIST :
1755                       OPf_WANT_SCALAR);
1756     if (flags & G_KEEPERR)
1757         myop.op_flags |= OPf_SPECIAL;
1758
1759 #ifdef PERL_FLEXIBLE_EXCEPTIONS
1760  redo_body:
1761     CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_vcall_body),
1762                 (OP*)&myop, TRUE);
1763 #else
1764     JMPENV_PUSH(ret);
1765 #endif
1766     switch (ret) {
1767     case 0:
1768 #ifndef PERL_FLEXIBLE_EXCEPTIONS
1769  redo_body:
1770         call_body((OP*)&myop,TRUE);
1771 #endif
1772         retval = PL_stack_sp - (PL_stack_base + oldmark);
1773         if (!(flags & G_KEEPERR))
1774             sv_setpv(ERRSV,"");
1775         break;
1776     case 1:
1777         STATUS_ALL_FAILURE;
1778         /* FALL THROUGH */
1779     case 2:
1780         /* my_exit() was called */
1781         PL_curstash = PL_defstash;
1782         FREETMPS;
1783         JMPENV_POP;
1784         if (PL_statusvalue && !(PL_exit_flags & PERL_EXIT_EXPECTED))
1785             Perl_croak(aTHX_ "Callback called exit");
1786         my_exit_jump();
1787         /* NOTREACHED */
1788     case 3:
1789         if (PL_restartop) {
1790             PL_op = PL_restartop;
1791             PL_restartop = 0;
1792             goto redo_body;
1793         }
1794         PL_stack_sp = PL_stack_base + oldmark;
1795         if (flags & G_ARRAY)
1796             retval = 0;
1797         else {
1798             retval = 1;
1799             *++PL_stack_sp = &PL_sv_undef;
1800         }
1801         break;
1802     }
1803
1804     JMPENV_POP;
1805     if (flags & G_DISCARD) {
1806         PL_stack_sp = PL_stack_base + oldmark;
1807         retval = 0;
1808         FREETMPS;
1809         LEAVE;
1810     }
1811     PL_op = oldop;
1812     return retval;
1813 }
1814
1815 /*
1816 =for apidoc p||eval_pv
1817
1818 Tells Perl to C<eval> the given string and return an SV* result.
1819
1820 =cut
1821 */
1822
1823 SV*
1824 Perl_eval_pv(pTHX_ const char *p, I32 croak_on_error)
1825 {
1826     dSP;
1827     SV* sv = newSVpv(p, 0);
1828
1829     PUSHMARK(SP);
1830     eval_sv(sv, G_SCALAR);
1831     SvREFCNT_dec(sv);
1832
1833     SPAGAIN;
1834     sv = POPs;
1835     PUTBACK;
1836
1837     if (croak_on_error && SvTRUE(ERRSV)) {
1838         STRLEN n_a;
1839         Perl_croak(aTHX_ SvPVx(ERRSV, n_a));
1840     }
1841
1842     return sv;
1843 }
1844
1845 /* Require a module. */
1846
1847 /*
1848 =for apidoc p||require_pv
1849
1850 Tells Perl to C<require> a module.
1851
1852 =cut
1853 */
1854
1855 void
1856 Perl_require_pv(pTHX_ const char *pv)
1857 {
1858     SV* sv;
1859     dSP;
1860     PUSHSTACKi(PERLSI_REQUIRE);
1861     PUTBACK;
1862     sv = sv_newmortal();
1863     sv_setpv(sv, "require '");
1864     sv_catpv(sv, pv);
1865     sv_catpv(sv, "'");
1866     eval_sv(sv, G_DISCARD);
1867     SPAGAIN;
1868     POPSTACK;
1869 }
1870
1871 void
1872 Perl_magicname(pTHX_ char *sym, char *name, I32 namlen)
1873 {
1874     register GV *gv;
1875
1876     if (gv = gv_fetchpv(sym,TRUE, SVt_PV))
1877         sv_magic(GvSV(gv), (SV*)gv, 0, name, namlen);
1878 }
1879
1880 STATIC void
1881 S_usage(pTHX_ char *name)               /* XXX move this out into a module ? */
1882 {
1883     /* This message really ought to be max 23 lines.
1884      * Removed -h because the user already knows that opton. Others? */
1885
1886     static char *usage_msg[] = {
1887 "-0[octal]       specify record separator (\\0, if no argument)",
1888 "-a              autosplit mode with -n or -p (splits $_ into @F)",
1889 "-C              enable native wide character system interfaces",
1890 "-c              check syntax only (runs BEGIN and END blocks)",
1891 "-d[:debugger]   run program under debugger",
1892 "-D[number/list] set debugging flags (argument is a bit mask or alphabets)",
1893 "-e 'command'    one line of program (several -e's allowed, omit programfile)",
1894 "-F/pattern/     split() pattern for -a switch (//'s are optional)",
1895 "-i[extension]   edit <> files in place (makes backup if extension supplied)",
1896 "-Idirectory     specify @INC/#include directory (several -I's allowed)",
1897 "-l[octal]       enable line ending processing, specifies line terminator",
1898 "-[mM][-]module  execute `use/no module...' before executing program",
1899 "-n              assume 'while (<>) { ... }' loop around program",
1900 "-p              assume loop like -n but print line also, like sed",
1901 "-P              run program through C preprocessor before compilation",
1902 "-s              enable rudimentary parsing for switches after programfile",
1903 "-S              look for programfile using PATH environment variable",
1904 "-T              enable tainting checks",
1905 "-u              dump core after parsing program",
1906 "-U              allow unsafe operations",
1907 "-v              print version, subversion (includes VERY IMPORTANT perl info)",
1908 "-V[:variable]   print configuration summary (or a single Config.pm variable)",
1909 "-w              enable many useful warnings (RECOMMENDED)",
1910 "-W              enable all warnings",
1911 "-X              disable all warnings",
1912 "-x[directory]   strip off text before #!perl line and perhaps cd to directory",
1913 "\n",
1914 NULL
1915 };
1916     char **p = usage_msg;
1917
1918     printf("\nUsage: %s [switches] [--] [programfile] [arguments]", name);
1919     while (*p)
1920         printf("\n  %s", *p++);
1921 }
1922
1923 /* This routine handles any switches that can be given during run */
1924
1925 char *
1926 Perl_moreswitches(pTHX_ char *s)
1927 {
1928     I32 numlen;
1929     U32 rschar;
1930
1931     switch (*s) {
1932     case '0':
1933     {
1934         dTHR;
1935         rschar = (U32)scan_oct(s, 4, &numlen);
1936         SvREFCNT_dec(PL_nrs);
1937         if (rschar & ~((U8)~0))
1938             PL_nrs = &PL_sv_undef;
1939         else if (!rschar && numlen >= 2)
1940             PL_nrs = newSVpvn("", 0);
1941         else {
1942             char ch = rschar;
1943             PL_nrs = newSVpvn(&ch, 1);
1944         }
1945         return s + numlen;
1946     }
1947     case 'C':
1948         PL_widesyscalls = TRUE;
1949         s++;
1950         return s;
1951     case 'F':
1952         PL_minus_F = TRUE;
1953         PL_splitstr = savepv(s + 1);
1954         s += strlen(s);
1955         return s;
1956     case 'a':
1957         PL_minus_a = TRUE;
1958         s++;
1959         return s;
1960     case 'c':
1961         PL_minus_c = TRUE;
1962         s++;
1963         return s;
1964     case 'd':
1965         forbid_setid("-d");
1966         s++;
1967         if (*s == ':' || *s == '=')  {
1968             my_setenv("PERL5DB", Perl_form(aTHX_ "use Devel::%s;", ++s));
1969             s += strlen(s);
1970         }
1971         if (!PL_perldb) {
1972             PL_perldb = PERLDB_ALL;
1973             init_debugger();
1974         }
1975         return s;
1976     case 'D':
1977     {
1978 #ifdef DEBUGGING
1979         forbid_setid("-D");
1980         if (isALPHA(s[1])) {
1981             static char debopts[] = "psltocPmfrxuLHXDS";
1982             char *d;
1983
1984             for (s++; *s && (d = strchr(debopts,*s)); s++)
1985                 PL_debug |= 1 << (d - debopts);
1986         }
1987         else {
1988             PL_debug = atoi(s+1);
1989             for (s++; isDIGIT(*s); s++) ;
1990         }
1991         PL_debug |= 0x80000000;
1992 #else
1993         dTHR;
1994         if (ckWARN_d(WARN_DEBUGGING))
1995             Perl_warner(aTHX_ WARN_DEBUGGING,
1996                    "Recompile perl with -DDEBUGGING to use -D switch\n");
1997         for (s++; isALNUM(*s); s++) ;
1998 #endif
1999         /*SUPPRESS 530*/
2000         return s;
2001     }
2002     case 'h':
2003         usage(PL_origargv[0]);
2004         PerlProc_exit(0);
2005     case 'i':
2006         if (PL_inplace)
2007             Safefree(PL_inplace);
2008         PL_inplace = savepv(s+1);
2009         /*SUPPRESS 530*/
2010         for (s = PL_inplace; *s && !isSPACE(*s); s++) ;
2011         if (*s) {
2012             *s++ = '\0';
2013             if (*s == '-')      /* Additional switches on #! line. */
2014                 s++;
2015         }
2016         return s;
2017     case 'I':   /* -I handled both here and in parse_perl() */
2018         forbid_setid("-I");
2019         ++s;
2020         while (*s && isSPACE(*s))
2021             ++s;
2022         if (*s) {
2023             char *e, *p;
2024             p = s;
2025             /* ignore trailing spaces (possibly followed by other switches) */
2026             do {
2027                 for (e = p; *e && !isSPACE(*e); e++) ;
2028                 p = e;
2029                 while (isSPACE(*p))
2030                     p++;
2031             } while (*p && *p != '-');
2032             e = savepvn(s, e-s);
2033             incpush(e, TRUE);
2034             Safefree(e);
2035             s = p;
2036             if (*s == '-')
2037                 s++;
2038         }
2039         else
2040             Perl_croak(aTHX_ "No directory specified for -I");
2041         return s;
2042     case 'l':
2043         PL_minus_l = TRUE;
2044         s++;
2045         if (PL_ors)
2046             Safefree(PL_ors);
2047         if (isDIGIT(*s)) {
2048             PL_ors = savepv("\n");
2049             PL_orslen = 1;
2050             *PL_ors = (char)scan_oct(s, 3 + (*s == '0'), &numlen);
2051             s += numlen;
2052         }
2053         else {
2054             dTHR;
2055             if (RsPARA(PL_nrs)) {
2056                 PL_ors = "\n\n";
2057                 PL_orslen = 2;
2058             }
2059             else
2060                 PL_ors = SvPV(PL_nrs, PL_orslen);
2061             PL_ors = savepvn(PL_ors, PL_orslen);
2062         }
2063         return s;
2064     case 'M':
2065         forbid_setid("-M");     /* XXX ? */
2066         /* FALL THROUGH */
2067     case 'm':
2068         forbid_setid("-m");     /* XXX ? */
2069         if (*++s) {
2070             char *start;
2071             SV *sv;
2072             char *use = "use ";
2073             /* -M-foo == 'no foo'       */
2074             if (*s == '-') { use = "no "; ++s; }
2075             sv = newSVpv(use,0);
2076             start = s;
2077             /* We allow -M'Module qw(Foo Bar)'  */
2078             while(isALNUM(*s) || *s==':') ++s;
2079             if (*s != '=') {
2080                 sv_catpv(sv, start);
2081                 if (*(start-1) == 'm') {
2082                     if (*s != '\0')
2083                         Perl_croak(aTHX_ "Can't use '%c' after -mname", *s);
2084                     sv_catpv( sv, " ()");
2085                 }
2086             } else {
2087                 sv_catpvn(sv, start, s-start);
2088                 sv_catpv(sv, " split(/,/,q{");
2089                 sv_catpv(sv, ++s);
2090                 sv_catpv(sv,    "})");
2091             }
2092             s += strlen(s);
2093             if (!PL_preambleav)
2094                 PL_preambleav = newAV();
2095             av_push(PL_preambleav, sv);
2096         }
2097         else
2098             Perl_croak(aTHX_ "No space allowed after -%c", *(s-1));
2099         return s;
2100     case 'n':
2101         PL_minus_n = TRUE;
2102         s++;
2103         return s;
2104     case 'p':
2105         PL_minus_p = TRUE;
2106         s++;
2107         return s;
2108     case 's':
2109         forbid_setid("-s");
2110         PL_doswitches = TRUE;
2111         s++;
2112         return s;
2113     case 'T':
2114         if (!PL_tainting)
2115             Perl_croak(aTHX_ "Too late for \"-T\" option");
2116         s++;
2117         return s;
2118     case 'u':
2119         PL_do_undump = TRUE;
2120         s++;
2121         return s;
2122     case 'U':
2123         PL_unsafe = TRUE;
2124         s++;
2125         return s;
2126     case 'v':
2127         printf(Perl_form(aTHX_ "\nThis is perl, v%vd built for %s",
2128                          PL_patchlevel, ARCHNAME));
2129 #if defined(LOCAL_PATCH_COUNT)
2130         if (LOCAL_PATCH_COUNT > 0)
2131             printf("\n(with %d registered patch%s, see perl -V for more detail)",
2132                 (int)LOCAL_PATCH_COUNT, (LOCAL_PATCH_COUNT!=1) ? "es" : "");
2133 #endif
2134
2135         printf("\n\nCopyright 1987-2000, Larry Wall\n");
2136 #ifdef MSDOS
2137         printf("\nMS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n");
2138 #endif
2139 #ifdef DJGPP
2140         printf("djgpp v2 port (jpl5003c) by Hirofumi Watanabe, 1996\n");
2141         printf("djgpp v2 port (perl5004+) by Laszlo Molnar, 1997-1999\n");
2142 #endif
2143 #ifdef OS2
2144         printf("\n\nOS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n"
2145             "Version 5 port Copyright (c) 1994-1999, Andreas Kaiser, Ilya Zakharevich\n");
2146 #endif
2147 #ifdef atarist
2148         printf("atariST series port, ++jrb  bammi@cadence.com\n");
2149 #endif
2150 #ifdef __BEOS__
2151         printf("BeOS port Copyright Tom Spindler, 1997-1999\n");
2152 #endif
2153 #ifdef MPE
2154         printf("MPE/iX port Copyright by Mark Klein and Mark Bixby, 1996-1999\n");
2155 #endif
2156 #ifdef OEMVS
2157         printf("MVS (OS390) port by Mortice Kern Systems, 1997-1999\n");
2158 #endif
2159 #ifdef __VOS__
2160         printf("Stratus VOS port by Paul_Green@stratus.com, 1997-1999\n");
2161 #endif
2162 #ifdef __OPEN_VM
2163         printf("VM/ESA port by Neale Ferguson, 1998-1999\n");
2164 #endif
2165 #ifdef POSIX_BC
2166         printf("BS2000 (POSIX) port by Start Amadeus GmbH, 1998-1999\n");
2167 #endif
2168 #ifdef __MINT__
2169         printf("MiNT port by Guido Flohr, 1997-1999\n");
2170 #endif
2171 #ifdef EPOC
2172         printf("EPOC port by Olaf Flebbe, 1999-2000\n");
2173 #endif
2174 #ifdef BINARY_BUILD_NOTICE
2175         BINARY_BUILD_NOTICE;
2176 #endif
2177         printf("\n\
2178 Perl may be copied only under the terms of either the Artistic License or the\n\
2179 GNU General Public License, which may be found in the Perl 5.0 source kit.\n\n\
2180 Complete documentation for Perl, including FAQ lists, should be found on\n\
2181 this system using `man perl' or `perldoc perl'.  If you have access to the\n\
2182 Internet, point your browser at http://www.perl.com/, the Perl Home Page.\n\n");
2183         PerlProc_exit(0);
2184     case 'w':
2185         if (! (PL_dowarn & G_WARN_ALL_MASK))
2186             PL_dowarn |= G_WARN_ON;
2187         s++;
2188         return s;
2189     case 'W':
2190         PL_dowarn = G_WARN_ALL_ON|G_WARN_ON;
2191         PL_compiling.cop_warnings = WARN_ALL ;
2192         s++;
2193         return s;
2194     case 'X':
2195         PL_dowarn = G_WARN_ALL_OFF;
2196         PL_compiling.cop_warnings = WARN_NONE ;
2197         s++;
2198         return s;
2199     case '*':
2200     case ' ':
2201         if (s[1] == '-')        /* Additional switches on #! line. */
2202             return s+2;
2203         break;
2204     case '-':
2205     case 0:
2206 #if defined(WIN32) || !defined(PERL_STRICT_CR)
2207     case '\r':
2208 #endif
2209     case '\n':
2210     case '\t':
2211         break;
2212 #ifdef ALTERNATE_SHEBANG
2213     case 'S':                   /* OS/2 needs -S on "extproc" line. */
2214         break;
2215 #endif
2216     case 'P':
2217         if (PL_preprocess)
2218             return s+1;
2219         /* FALL THROUGH */
2220     default:
2221         Perl_croak(aTHX_ "Can't emulate -%.1s on #! line",s);
2222     }
2223     return Nullch;
2224 }
2225
2226 /* compliments of Tom Christiansen */
2227
2228 /* unexec() can be found in the Gnu emacs distribution */
2229 /* Known to work with -DUNEXEC and using unexelf.c from GNU emacs-20.2 */
2230
2231 void
2232 Perl_my_unexec(pTHX)
2233 {
2234 #ifdef UNEXEC
2235     SV*    prog;
2236     SV*    file;
2237     int    status = 1;
2238     extern int etext;
2239
2240     prog = newSVpv(BIN_EXP, 0);
2241     sv_catpv(prog, "/perl");
2242     file = newSVpv(PL_origfilename, 0);
2243     sv_catpv(file, ".perldump");
2244
2245     unexec(SvPVX(file), SvPVX(prog), &etext, sbrk(0), 0);
2246     /* unexec prints msg to stderr in case of failure */
2247     PerlProc_exit(status);
2248 #else
2249 #  ifdef VMS
2250 #    include <lib$routines.h>
2251      lib$signal(SS$_DEBUG);  /* ssdef.h #included from vmsish.h */
2252 #  else
2253     ABORT();            /* for use with undump */
2254 #  endif
2255 #endif
2256 }
2257
2258 /* initialize curinterp */
2259 STATIC void
2260 S_init_interp(pTHX)
2261 {
2262
2263 #ifdef PERL_OBJECT              /* XXX kludge */
2264 #define I_REINIT \
2265   STMT_START {                          \
2266     PL_chopset          = " \n-";       \
2267     PL_copline          = NOLINE;       \
2268     PL_curcop           = &PL_compiling;\
2269     PL_curcopdb         = NULL;         \
2270     PL_dbargs           = 0;            \
2271     PL_dumpindent       = 4;            \
2272     PL_laststatval      = -1;           \
2273     PL_laststype        = OP_STAT;      \
2274     PL_maxscream        = -1;           \
2275     PL_maxsysfd         = MAXSYSFD;     \
2276     PL_statname         = Nullsv;       \
2277     PL_tmps_floor       = -1;           \
2278     PL_tmps_ix          = -1;           \
2279     PL_op_mask          = NULL;         \
2280     PL_laststatval      = -1;           \
2281     PL_laststype        = OP_STAT;      \
2282     PL_mess_sv          = Nullsv;       \
2283     PL_splitstr         = " ";          \
2284     PL_generation       = 100;          \
2285     PL_exitlist         = NULL;         \
2286     PL_exitlistlen      = 0;            \
2287     PL_regindent        = 0;            \
2288     PL_in_clean_objs    = FALSE;        \
2289     PL_in_clean_all     = FALSE;        \
2290     PL_profiledata      = NULL;         \
2291     PL_rsfp             = Nullfp;       \
2292     PL_rsfp_filters     = Nullav;       \
2293     PL_dirty            = FALSE;        \
2294   } STMT_END
2295     I_REINIT;
2296 #else
2297 #  ifdef MULTIPLICITY
2298 #    define PERLVAR(var,type)
2299 #    define PERLVARA(var,n,type)
2300 #    if defined(PERL_IMPLICIT_CONTEXT)
2301 #      if defined(USE_THREADS)
2302 #        define PERLVARI(var,type,init)         PERL_GET_INTERP->var = init;
2303 #        define PERLVARIC(var,type,init)        PERL_GET_INTERP->var = init;
2304 #      else /* !USE_THREADS */
2305 #        define PERLVARI(var,type,init)         aTHX->var = init;
2306 #        define PERLVARIC(var,type,init)        aTHX->var = init;
2307 #      endif /* USE_THREADS */
2308 #    else
2309 #      define PERLVARI(var,type,init)   PERL_GET_INTERP->var = init;
2310 #      define PERLVARIC(var,type,init)  PERL_GET_INTERP->var = init;
2311 #    endif
2312 #    include "intrpvar.h"
2313 #    ifndef USE_THREADS
2314 #      include "thrdvar.h"
2315 #    endif
2316 #    undef PERLVAR
2317 #    undef PERLVARA
2318 #    undef PERLVARI
2319 #    undef PERLVARIC
2320 #  else
2321 #    define PERLVAR(var,type)
2322 #    define PERLVARA(var,n,type)
2323 #    define PERLVARI(var,type,init)     PL_##var = init;
2324 #    define PERLVARIC(var,type,init)    PL_##var = init;
2325 #    include "intrpvar.h"
2326 #    ifndef USE_THREADS
2327 #      include "thrdvar.h"
2328 #    endif
2329 #    undef PERLVAR
2330 #    undef PERLVARA
2331 #    undef PERLVARI
2332 #    undef PERLVARIC
2333 #  endif
2334 #endif
2335
2336 }
2337
2338 STATIC void
2339 S_init_main_stash(pTHX)
2340 {
2341     dTHR;
2342     GV *gv;
2343
2344     /* Note that strtab is a rather special HV.  Assumptions are made
2345        about not iterating on it, and not adding tie magic to it.
2346        It is properly deallocated in perl_destruct() */
2347     PL_strtab = newHV();
2348 #ifdef USE_THREADS
2349     MUTEX_INIT(&PL_strtab_mutex);
2350 #endif
2351     HvSHAREKEYS_off(PL_strtab);                 /* mandatory */
2352     hv_ksplit(PL_strtab, 512);
2353
2354     PL_curstash = PL_defstash = newHV();
2355     PL_curstname = newSVpvn("main",4);
2356     gv = gv_fetchpv("main::",TRUE, SVt_PVHV);
2357     SvREFCNT_dec(GvHV(gv));
2358     GvHV(gv) = (HV*)SvREFCNT_inc(PL_defstash);
2359     SvREADONLY_on(gv);
2360     HvNAME(PL_defstash) = savepv("main");
2361     PL_incgv = gv_HVadd(gv_AVadd(gv_fetchpv("INC",TRUE, SVt_PVAV)));
2362     GvMULTI_on(PL_incgv);
2363     PL_hintgv = gv_fetchpv("\010",TRUE, SVt_PV); /* ^H */
2364     GvMULTI_on(PL_hintgv);
2365     PL_defgv = gv_fetchpv("_",TRUE, SVt_PVAV);
2366     PL_errgv = gv_HVadd(gv_fetchpv("@", TRUE, SVt_PV));
2367     GvMULTI_on(PL_errgv);
2368     PL_replgv = gv_fetchpv("\022", TRUE, SVt_PV); /* ^R */
2369     GvMULTI_on(PL_replgv);
2370     (void)Perl_form(aTHX_ "%240s","");  /* Preallocate temp - for immediate signals. */
2371     sv_grow(ERRSV, 240);        /* Preallocate - for immediate signals. */
2372     sv_setpvn(ERRSV, "", 0);
2373     PL_curstash = PL_defstash;
2374     CopSTASH_set(&PL_compiling, PL_defstash);
2375     PL_debstash = GvHV(gv_fetchpv("DB::", GV_ADDMULTI, SVt_PVHV));
2376     PL_globalstash = GvHV(gv_fetchpv("CORE::GLOBAL::", GV_ADDMULTI, SVt_PVHV));
2377     /* We must init $/ before switches are processed. */
2378     sv_setpvn(get_sv("/", TRUE), "\n", 1);
2379 }
2380
2381 STATIC void
2382 S_open_script(pTHX_ char *scriptname, bool dosearch, SV *sv, int *fdscript)
2383 {
2384     dTHR;
2385     register char *s;
2386
2387     *fdscript = -1;
2388
2389     if (PL_e_script) {
2390         PL_origfilename = savepv("-e");
2391     }
2392     else {
2393         /* if find_script() returns, it returns a malloc()-ed value */
2394         PL_origfilename = scriptname = find_script(scriptname, dosearch, NULL, 1);
2395
2396         if (strnEQ(scriptname, "/dev/fd/", 8) && isDIGIT(scriptname[8]) ) {
2397             char *s = scriptname + 8;
2398             *fdscript = atoi(s);
2399             while (isDIGIT(*s))
2400                 s++;
2401             if (*s) {
2402                 scriptname = savepv(s + 1);
2403                 Safefree(PL_origfilename);
2404                 PL_origfilename = scriptname;
2405             }
2406         }
2407     }
2408
2409     CopFILE_set(PL_curcop, PL_origfilename);
2410     if (strEQ(PL_origfilename,"-"))
2411         scriptname = "";
2412     if (*fdscript >= 0) {
2413         PL_rsfp = PerlIO_fdopen(*fdscript,PERL_SCRIPT_MODE);
2414 #if defined(HAS_FCNTL) && defined(F_SETFD)
2415         if (PL_rsfp)
2416             fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,1);  /* ensure close-on-exec */
2417 #endif
2418     }
2419     else if (PL_preprocess) {
2420         char *cpp_cfg = CPPSTDIN;
2421         SV *cpp = newSVpvn("",0);
2422         SV *cmd = NEWSV(0,0);
2423
2424         if (strEQ(cpp_cfg, "cppstdin"))
2425             Perl_sv_catpvf(aTHX_ cpp, "%s/", BIN_EXP);
2426         sv_catpv(cpp, cpp_cfg);
2427
2428         sv_catpvn(sv, "-I", 2);
2429         sv_catpv(sv,PRIVLIB_EXP);
2430
2431 #ifdef MSDOS
2432         Perl_sv_setpvf(aTHX_ cmd, "\
2433 sed %s -e \"/^[^#]/b\" \
2434  -e \"/^#[      ]*include[      ]/b\" \
2435  -e \"/^#[      ]*define[       ]/b\" \
2436  -e \"/^#[      ]*if[   ]/b\" \
2437  -e \"/^#[      ]*ifdef[        ]/b\" \
2438  -e \"/^#[      ]*ifndef[       ]/b\" \
2439  -e \"/^#[      ]*else/b\" \
2440  -e \"/^#[      ]*elif[         ]/b\" \
2441  -e \"/^#[      ]*undef[        ]/b\" \
2442  -e \"/^#[      ]*endif/b\" \
2443  -e \"s/^#.*//\" \
2444  %s | %"SVf" -C %"SVf" %s",
2445           (PL_doextract ? "-e \"1,/^#/d\n\"" : ""),
2446 #else
2447 #  ifdef __OPEN_VM
2448         Perl_sv_setpvf(aTHX_ cmd, "\
2449 %s %s -e '/^[^#]/b' \
2450  -e '/^#[       ]*include[      ]/b' \
2451  -e '/^#[       ]*define[       ]/b' \
2452  -e '/^#[       ]*if[   ]/b' \
2453  -e '/^#[       ]*ifdef[        ]/b' \
2454  -e '/^#[       ]*ifndef[       ]/b' \
2455  -e '/^#[       ]*else/b' \
2456  -e '/^#[       ]*elif[         ]/b' \
2457  -e '/^#[       ]*undef[        ]/b' \
2458  -e '/^#[       ]*endif/b' \
2459  -e 's/^[       ]*#.*//' \
2460  %s | %"SVf" %"SVf" %s",
2461 #  else
2462         Perl_sv_setpvf(aTHX_ cmd, "\
2463 %s %s -e '/^[^#]/b' \
2464  -e '/^#[       ]*include[      ]/b' \
2465  -e '/^#[       ]*define[       ]/b' \
2466  -e '/^#[       ]*if[   ]/b' \
2467  -e '/^#[       ]*ifdef[        ]/b' \
2468  -e '/^#[       ]*ifndef[       ]/b' \
2469  -e '/^#[       ]*else/b' \
2470  -e '/^#[       ]*elif[         ]/b' \
2471  -e '/^#[       ]*undef[        ]/b' \
2472  -e '/^#[       ]*endif/b' \
2473  -e 's/^[       ]*#.*//' \
2474  %s | %"SVf" -C %"SVf" %s",
2475 #  endif
2476 #ifdef LOC_SED
2477           LOC_SED,
2478 #else
2479           "sed",
2480 #endif
2481           (PL_doextract ? "-e '1,/^#/d\n'" : ""),
2482 #endif
2483           scriptname, cpp, sv, CPPMINUS);
2484         PL_doextract = FALSE;
2485 #ifdef IAMSUID                          /* actually, this is caught earlier */
2486         if (PL_euid != PL_uid && !PL_euid) {    /* if running suidperl */
2487 #ifdef HAS_SETEUID
2488             (void)seteuid(PL_uid);              /* musn't stay setuid root */
2489 #else
2490 #ifdef HAS_SETREUID
2491             (void)setreuid((Uid_t)-1, PL_uid);
2492 #else
2493 #ifdef HAS_SETRESUID
2494             (void)setresuid((Uid_t)-1, PL_uid, (Uid_t)-1);
2495 #else
2496             PerlProc_setuid(PL_uid);
2497 #endif
2498 #endif
2499 #endif
2500             if (PerlProc_geteuid() != PL_uid)
2501                 Perl_croak(aTHX_ "Can't do seteuid!\n");
2502         }
2503 #endif /* IAMSUID */
2504         PL_rsfp = PerlProc_popen(SvPVX(cmd), "r");
2505         SvREFCNT_dec(cmd);
2506         SvREFCNT_dec(cpp);
2507     }
2508     else if (!*scriptname) {
2509         forbid_setid("program input from stdin");
2510         PL_rsfp = PerlIO_stdin();
2511     }
2512     else {
2513         PL_rsfp = PerlIO_open(scriptname,PERL_SCRIPT_MODE);
2514 #if defined(HAS_FCNTL) && defined(F_SETFD)
2515         if (PL_rsfp)
2516             fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,1);  /* ensure close-on-exec */
2517 #endif
2518     }
2519     if (!PL_rsfp) {
2520 #ifdef DOSUID
2521 #ifndef IAMSUID         /* in case script is not readable before setuid */
2522         if (PL_euid &&
2523             PerlLIO_stat(CopFILE(PL_curcop),&PL_statbuf) >= 0 &&
2524             PL_statbuf.st_mode & (S_ISUID|S_ISGID))
2525         {
2526             /* try again */
2527             PerlProc_execv(Perl_form(aTHX_ "%s/sperl"PERL_FS_VER_FMT, BIN_EXP,
2528                                      (int)PERL_REVISION, (int)PERL_VERSION,
2529                                      (int)PERL_SUBVERSION), PL_origargv);
2530             Perl_croak(aTHX_ "Can't do setuid\n");
2531         }
2532 #endif
2533 #endif
2534         Perl_croak(aTHX_ "Can't open perl script \"%s\": %s\n",
2535                    CopFILE(PL_curcop), Strerror(errno));
2536     }
2537 }
2538
2539 /* Mention
2540  * I_SYSSTATVFS HAS_FSTATVFS
2541  * I_SYSMOUNT
2542  * I_STATFS     HAS_FSTATFS
2543  * I_MNTENT     HAS_GETMNTENT   HAS_HASMNTOPT
2544  * here so that metaconfig picks them up. */
2545
2546 #ifdef IAMSUID
2547 STATIC int
2548 S_fd_on_nosuid_fs(pTHX_ int fd)
2549 {
2550     int check_okay = 0; /* able to do all the required sys/libcalls */
2551     int on_nosuid  = 0; /* the fd is on a nosuid fs */
2552 /*
2553  * Preferred order: fstatvfs(), fstatfs(), ustat()+getmnt(), getmntent().
2554  * fstatvfs() is UNIX98.
2555  * fstatfs() is 4.3 BSD.
2556  * ustat()+getmnt() is pre-4.3 BSD.
2557  * getmntent() is O(number-of-mounted-filesystems) and can hang on
2558  * an irrelevant filesystem while trying to reach the right one.
2559  */
2560
2561 #   ifdef HAS_FSTATVFS
2562     struct statvfs stfs;
2563     check_okay = fstatvfs(fd, &stfs) == 0;
2564     on_nosuid  = check_okay && (stfs.f_flag  & ST_NOSUID);
2565 #   else
2566 #       ifdef PERL_MOUNT_NOSUID
2567 #           if defined(HAS_FSTATFS) && \
2568                defined(HAS_STRUCT_STATFS) && \
2569                defined(HAS_STRUCT_STATFS_F_FLAGS)
2570     struct statfs  stfs;
2571     check_okay = fstatfs(fd, &stfs)  == 0;
2572     on_nosuid  = check_okay && (stfs.f_flags & PERL_MOUNT_NOSUID);
2573 #           else
2574 #               if defined(HAS_FSTAT) && \
2575                    defined(HAS_USTAT) && \
2576                    defined(HAS_GETMNT) && \
2577                    defined(HAS_STRUCT_FS_DATA) && \
2578                    defined(NOSTAT_ONE)
2579     struct stat fdst;
2580     if (fstat(fd, &fdst) == 0) {
2581         struct ustat us;
2582         if (ustat(fdst.st_dev, &us) == 0) {
2583             struct fs_data fsd;
2584             /* NOSTAT_ONE here because we're not examining fields which
2585              * vary between that case and STAT_ONE. */
2586             if (getmnt((int*)0, &fsd, (int)0, NOSTAT_ONE, us.f_fname) == 0) {
2587                 size_t cmplen = sizeof(us.f_fname);
2588                 if (sizeof(fsd.fd_req.path) < cmplen)
2589                     cmplen = sizeof(fsd.fd_req.path);
2590                 if (strnEQ(fsd.fd_req.path, us.f_fname, cmplen) &&
2591                     fdst.st_dev == fsd.fd_req.dev) {
2592                         check_okay = 1;
2593                         on_nosuid = fsd.fd_req.flags & PERL_MOUNT_NOSUID;
2594                     }
2595                 }
2596             }
2597         }
2598     }
2599 #               endif /* fstat+ustat+getmnt */
2600 #           endif /* fstatfs */
2601 #       else
2602 #           if defined(HAS_GETMNTENT) && \
2603                defined(HAS_HASMNTOPT) && \
2604                defined(MNTOPT_NOSUID)
2605     FILE                *mtab = fopen("/etc/mtab", "r");
2606     struct mntent       *entry;
2607     struct stat         stb, fsb;
2608
2609     if (mtab && (fstat(fd, &stb) == 0)) {
2610         while (entry = getmntent(mtab)) {
2611             if (stat(entry->mnt_dir, &fsb) == 0
2612                 && fsb.st_dev == stb.st_dev)
2613             {
2614                 /* found the filesystem */
2615                 check_okay = 1;
2616                 if (hasmntopt(entry, MNTOPT_NOSUID))
2617                     on_nosuid = 1;
2618                 break;
2619             } /* A single fs may well fail its stat(). */
2620         }
2621     }
2622     if (mtab)
2623         fclose(mtab);
2624 #           endif /* getmntent+hasmntopt */
2625 #       endif /* PERL_MOUNT_NOSUID: fstatfs or fstat+ustat+statfs */
2626 #   endif /* statvfs */
2627
2628     if (!check_okay)
2629         Perl_croak(aTHX_ "Can't check filesystem of script \"%s\" for nosuid", PL_origfilename);
2630     return on_nosuid;
2631 }
2632 #endif /* IAMSUID */
2633
2634 STATIC void
2635 S_validate_suid(pTHX_ char *validarg, char *scriptname, int fdscript)
2636 {
2637     int which;
2638
2639     /* do we need to emulate setuid on scripts? */
2640
2641     /* This code is for those BSD systems that have setuid #! scripts disabled
2642      * in the kernel because of a security problem.  Merely defining DOSUID
2643      * in perl will not fix that problem, but if you have disabled setuid
2644      * scripts in the kernel, this will attempt to emulate setuid and setgid
2645      * on scripts that have those now-otherwise-useless bits set.  The setuid
2646      * root version must be called suidperl or sperlN.NNN.  If regular perl
2647      * discovers that it has opened a setuid script, it calls suidperl with
2648      * the same argv that it had.  If suidperl finds that the script it has
2649      * just opened is NOT setuid root, it sets the effective uid back to the
2650      * uid.  We don't just make perl setuid root because that loses the
2651      * effective uid we had before invoking perl, if it was different from the
2652      * uid.
2653      *
2654      * DOSUID must be defined in both perl and suidperl, and IAMSUID must
2655      * be defined in suidperl only.  suidperl must be setuid root.  The
2656      * Configure script will set this up for you if you want it.
2657      */
2658
2659 #ifdef DOSUID
2660     dTHR;
2661     char *s, *s2;
2662
2663     if (PerlLIO_fstat(PerlIO_fileno(PL_rsfp),&PL_statbuf) < 0)  /* normal stat is insecure */
2664         Perl_croak(aTHX_ "Can't stat script \"%s\"",PL_origfilename);
2665     if (fdscript < 0 && PL_statbuf.st_mode & (S_ISUID|S_ISGID)) {
2666         I32 len;
2667         STRLEN n_a;
2668
2669 #ifdef IAMSUID
2670 #ifndef HAS_SETREUID
2671         /* On this access check to make sure the directories are readable,
2672          * there is actually a small window that the user could use to make
2673          * filename point to an accessible directory.  So there is a faint
2674          * chance that someone could execute a setuid script down in a
2675          * non-accessible directory.  I don't know what to do about that.
2676          * But I don't think it's too important.  The manual lies when
2677          * it says access() is useful in setuid programs.
2678          */
2679         if (PerlLIO_access(CopFILE(PL_curcop),1)) /*double check*/
2680             Perl_croak(aTHX_ "Permission denied");
2681 #else
2682         /* If we can swap euid and uid, then we can determine access rights
2683          * with a simple stat of the file, and then compare device and
2684          * inode to make sure we did stat() on the same file we opened.
2685          * Then we just have to make sure he or she can execute it.
2686          */
2687         {
2688             struct stat tmpstatbuf;
2689
2690             if (
2691 #ifdef HAS_SETREUID
2692                 setreuid(PL_euid,PL_uid) < 0
2693 #else
2694 # if HAS_SETRESUID
2695                 setresuid(PL_euid,PL_uid,(Uid_t)-1) < 0
2696 # endif
2697 #endif
2698                 || PerlProc_getuid() != PL_euid || PerlProc_geteuid() != PL_uid)
2699                 Perl_croak(aTHX_ "Can't swap uid and euid");    /* really paranoid */
2700             if (PerlLIO_stat(CopFILE(PL_curcop),&tmpstatbuf) < 0)
2701                 Perl_croak(aTHX_ "Permission denied");  /* testing full pathname here */
2702 #if defined(IAMSUID) && !defined(NO_NOSUID_CHECK)
2703             if (fd_on_nosuid_fs(PerlIO_fileno(PL_rsfp)))
2704                 Perl_croak(aTHX_ "Permission denied");
2705 #endif
2706             if (tmpstatbuf.st_dev != PL_statbuf.st_dev ||
2707                 tmpstatbuf.st_ino != PL_statbuf.st_ino) {
2708                 (void)PerlIO_close(PL_rsfp);
2709                 if (PL_rsfp = PerlProc_popen("/bin/mail root","w")) {   /* heh, heh */
2710                     PerlIO_printf(PL_rsfp,
2711 "User %"Uid_t_f" tried to run dev %ld ino %ld in place of dev %ld ino %ld!\n\
2712 (Filename of set-id script was %s, uid %"Uid_t_f" gid %"Gid_t_f".)\n\nSincerely,\nperl\n",
2713                         PL_uid,(long)tmpstatbuf.st_dev, (long)tmpstatbuf.st_ino,
2714                         (long)PL_statbuf.st_dev, (long)PL_statbuf.st_ino,
2715                         CopFILE(PL_curcop),
2716                         PL_statbuf.st_uid, PL_statbuf.st_gid);
2717                     (void)PerlProc_pclose(PL_rsfp);
2718                 }
2719                 Perl_croak(aTHX_ "Permission denied\n");
2720             }
2721             if (
2722 #ifdef HAS_SETREUID
2723               setreuid(PL_uid,PL_euid) < 0
2724 #else
2725 # if defined(HAS_SETRESUID)
2726               setresuid(PL_uid,PL_euid,(Uid_t)-1) < 0
2727 # endif
2728 #endif
2729               || PerlProc_getuid() != PL_uid || PerlProc_geteuid() != PL_euid)
2730                 Perl_croak(aTHX_ "Can't reswap uid and euid");
2731             if (!cando(S_IXUSR,FALSE,&PL_statbuf))              /* can real uid exec? */
2732                 Perl_croak(aTHX_ "Permission denied\n");
2733         }
2734 #endif /* HAS_SETREUID */
2735 #endif /* IAMSUID */
2736
2737         if (!S_ISREG(PL_statbuf.st_mode))
2738             Perl_croak(aTHX_ "Permission denied");
2739         if (PL_statbuf.st_mode & S_IWOTH)
2740             Perl_croak(aTHX_ "Setuid/gid script is writable by world");
2741         PL_doswitches = FALSE;          /* -s is insecure in suid */
2742         CopLINE_inc(PL_curcop);
2743         if (sv_gets(PL_linestr, PL_rsfp, 0) == Nullch ||
2744           strnNE(SvPV(PL_linestr,n_a),"#!",2) ) /* required even on Sys V */
2745             Perl_croak(aTHX_ "No #! line");
2746         s = SvPV(PL_linestr,n_a)+2;
2747         if (*s == ' ') s++;
2748         while (!isSPACE(*s)) s++;
2749         for (s2 = s;  (s2 > SvPV(PL_linestr,n_a)+2 &&
2750                        (isDIGIT(s2[-1]) || strchr("._-", s2[-1])));  s2--) ;
2751         if (strnNE(s2-4,"perl",4) && strnNE(s-9,"perl",4))  /* sanity check */
2752             Perl_croak(aTHX_ "Not a perl script");
2753         while (*s == ' ' || *s == '\t') s++;
2754         /*
2755          * #! arg must be what we saw above.  They can invoke it by
2756          * mentioning suidperl explicitly, but they may not add any strange
2757          * arguments beyond what #! says if they do invoke suidperl that way.
2758          */
2759         len = strlen(validarg);
2760         if (strEQ(validarg," PHOOEY ") ||
2761             strnNE(s,validarg,len) || !isSPACE(s[len]))
2762             Perl_croak(aTHX_ "Args must match #! line");
2763
2764 #ifndef IAMSUID
2765         if (PL_euid != PL_uid && (PL_statbuf.st_mode & S_ISUID) &&
2766             PL_euid == PL_statbuf.st_uid)
2767             if (!PL_do_undump)
2768                 Perl_croak(aTHX_ "YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
2769 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
2770 #endif /* IAMSUID */
2771
2772         if (PL_euid) {  /* oops, we're not the setuid root perl */
2773             (void)PerlIO_close(PL_rsfp);
2774 #ifndef IAMSUID
2775             /* try again */
2776             PerlProc_execv(Perl_form(aTHX_ "%s/sperl"PERL_FS_VER_FMT, BIN_EXP,
2777                                      (int)PERL_REVISION, (int)PERL_VERSION,
2778                                      (int)PERL_SUBVERSION), PL_origargv);
2779 #endif
2780             Perl_croak(aTHX_ "Can't do setuid\n");
2781         }
2782
2783         if (PL_statbuf.st_mode & S_ISGID && PL_statbuf.st_gid != PL_egid) {
2784 #ifdef HAS_SETEGID
2785             (void)setegid(PL_statbuf.st_gid);
2786 #else
2787 #ifdef HAS_SETREGID
2788            (void)setregid((Gid_t)-1,PL_statbuf.st_gid);
2789 #else
2790 #ifdef HAS_SETRESGID
2791            (void)setresgid((Gid_t)-1,PL_statbuf.st_gid,(Gid_t)-1);
2792 #else
2793             PerlProc_setgid(PL_statbuf.st_gid);
2794 #endif
2795 #endif
2796 #endif
2797             if (PerlProc_getegid() != PL_statbuf.st_gid)
2798                 Perl_croak(aTHX_ "Can't do setegid!\n");
2799         }
2800         if (PL_statbuf.st_mode & S_ISUID) {
2801             if (PL_statbuf.st_uid != PL_euid)
2802 #ifdef HAS_SETEUID
2803                 (void)seteuid(PL_statbuf.st_uid);       /* all that for this */
2804 #else
2805 #ifdef HAS_SETREUID
2806                 (void)setreuid((Uid_t)-1,PL_statbuf.st_uid);
2807 #else
2808 #ifdef HAS_SETRESUID
2809                 (void)setresuid((Uid_t)-1,PL_statbuf.st_uid,(Uid_t)-1);
2810 #else
2811                 PerlProc_setuid(PL_statbuf.st_uid);
2812 #endif
2813 #endif
2814 #endif
2815             if (PerlProc_geteuid() != PL_statbuf.st_uid)
2816                 Perl_croak(aTHX_ "Can't do seteuid!\n");
2817         }
2818         else if (PL_uid) {                      /* oops, mustn't run as root */
2819 #ifdef HAS_SETEUID
2820           (void)seteuid((Uid_t)PL_uid);
2821 #else
2822 #ifdef HAS_SETREUID
2823           (void)setreuid((Uid_t)-1,(Uid_t)PL_uid);
2824 #else
2825 #ifdef HAS_SETRESUID
2826           (void)setresuid((Uid_t)-1,(Uid_t)PL_uid,(Uid_t)-1);
2827 #else
2828           PerlProc_setuid((Uid_t)PL_uid);
2829 #endif
2830 #endif
2831 #endif
2832             if (PerlProc_geteuid() != PL_uid)
2833                 Perl_croak(aTHX_ "Can't do seteuid!\n");
2834         }
2835         init_ids();
2836         if (!cando(S_IXUSR,TRUE,&PL_statbuf))
2837             Perl_croak(aTHX_ "Permission denied\n");    /* they can't do this */
2838     }
2839 #ifdef IAMSUID
2840     else if (PL_preprocess)
2841         Perl_croak(aTHX_ "-P not allowed for setuid/setgid script\n");
2842     else if (fdscript >= 0)
2843         Perl_croak(aTHX_ "fd script not allowed in suidperl\n");
2844     else
2845         Perl_croak(aTHX_ "Script is not setuid/setgid in suidperl\n");
2846
2847     /* We absolutely must clear out any saved ids here, so we */
2848     /* exec the real perl, substituting fd script for scriptname. */
2849     /* (We pass script name as "subdir" of fd, which perl will grok.) */
2850     PerlIO_rewind(PL_rsfp);
2851     PerlLIO_lseek(PerlIO_fileno(PL_rsfp),(Off_t)0,0);  /* just in case rewind didn't */
2852     for (which = 1; PL_origargv[which] && PL_origargv[which] != scriptname; which++) ;
2853     if (!PL_origargv[which])
2854         Perl_croak(aTHX_ "Permission denied");
2855     PL_origargv[which] = savepv(Perl_form(aTHX_ "/dev/fd/%d/%s",
2856                                   PerlIO_fileno(PL_rsfp), PL_origargv[which]));
2857 #if defined(HAS_FCNTL) && defined(F_SETFD)
2858     fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,0);    /* ensure no close-on-exec */
2859 #endif
2860     PerlProc_execv(Perl_form(aTHX_ "%s/perl"PERL_FS_VER_FMT, BIN_EXP,
2861                              (int)PERL_REVISION, (int)PERL_VERSION,
2862                              (int)PERL_SUBVERSION), PL_origargv);/* try again */
2863     Perl_croak(aTHX_ "Can't do setuid\n");
2864 #endif /* IAMSUID */
2865 #else /* !DOSUID */
2866     if (PL_euid != PL_uid || PL_egid != PL_gid) {       /* (suidperl doesn't exist, in fact) */
2867 #ifndef SETUID_SCRIPTS_ARE_SECURE_NOW
2868         dTHR;
2869         PerlLIO_fstat(PerlIO_fileno(PL_rsfp),&PL_statbuf);      /* may be either wrapped or real suid */
2870         if ((PL_euid != PL_uid && PL_euid == PL_statbuf.st_uid && PL_statbuf.st_mode & S_ISUID)
2871             ||
2872             (PL_egid != PL_gid && PL_egid == PL_statbuf.st_gid && PL_statbuf.st_mode & S_ISGID)
2873            )
2874             if (!PL_do_undump)
2875                 Perl_croak(aTHX_ "YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
2876 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
2877 #endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
2878         /* not set-id, must be wrapped */
2879     }
2880 #endif /* DOSUID */
2881 }
2882
2883 STATIC void
2884 S_find_beginning(pTHX)
2885 {
2886     register char *s, *s2;
2887
2888     /* skip forward in input to the real script? */
2889
2890     forbid_setid("-x");
2891     while (PL_doextract) {
2892         if ((s = sv_gets(PL_linestr, PL_rsfp, 0)) == Nullch)
2893             Perl_croak(aTHX_ "No Perl script found in input\n");
2894         if (*s == '#' && s[1] == '!' && (s = instr(s,"perl"))) {
2895             PerlIO_ungetc(PL_rsfp, '\n');               /* to keep line count right */
2896             PL_doextract = FALSE;
2897             while (*s && !(isSPACE (*s) || *s == '#')) s++;
2898             s2 = s;
2899             while (*s == ' ' || *s == '\t') s++;
2900             if (*s++ == '-') {
2901                 while (isDIGIT(s2[-1]) || strchr("-._", s2[-1])) s2--;
2902                 if (strnEQ(s2-4,"perl",4))
2903                     /*SUPPRESS 530*/
2904                     while (s = moreswitches(s)) ;
2905             }
2906         }
2907     }
2908 }
2909
2910
2911 STATIC void
2912 S_init_ids(pTHX)
2913 {
2914     PL_uid = PerlProc_getuid();
2915     PL_euid = PerlProc_geteuid();
2916     PL_gid = PerlProc_getgid();
2917     PL_egid = PerlProc_getegid();
2918 #ifdef VMS
2919     PL_uid |= PL_gid << 16;
2920     PL_euid |= PL_egid << 16;
2921 #endif
2922     PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2923 }
2924
2925 STATIC void
2926 S_forbid_setid(pTHX_ char *s)
2927 {
2928     if (PL_euid != PL_uid)
2929         Perl_croak(aTHX_ "No %s allowed while running setuid", s);
2930     if (PL_egid != PL_gid)
2931         Perl_croak(aTHX_ "No %s allowed while running setgid", s);
2932 }
2933
2934 void
2935 Perl_init_debugger(pTHX)
2936 {
2937     dTHR;
2938     HV *ostash = PL_curstash;
2939
2940     PL_curstash = PL_debstash;
2941     PL_dbargs = GvAV(gv_AVadd((gv_fetchpv("args", GV_ADDMULTI, SVt_PVAV))));
2942     AvREAL_off(PL_dbargs);
2943     PL_DBgv = gv_fetchpv("DB", GV_ADDMULTI, SVt_PVGV);
2944     PL_DBline = gv_fetchpv("dbline", GV_ADDMULTI, SVt_PVAV);
2945     PL_DBsub = gv_HVadd(gv_fetchpv("sub", GV_ADDMULTI, SVt_PVHV));
2946     sv_upgrade(GvSV(PL_DBsub), SVt_IV); /* IVX accessed if PERLDB_SUB_NN */
2947     PL_DBsingle = GvSV((gv_fetchpv("single", GV_ADDMULTI, SVt_PV)));
2948     sv_setiv(PL_DBsingle, 0);
2949     PL_DBtrace = GvSV((gv_fetchpv("trace", GV_ADDMULTI, SVt_PV)));
2950     sv_setiv(PL_DBtrace, 0);
2951     PL_DBsignal = GvSV((gv_fetchpv("signal", GV_ADDMULTI, SVt_PV)));
2952     sv_setiv(PL_DBsignal, 0);
2953     PL_curstash = ostash;
2954 }
2955
2956 #ifndef STRESS_REALLOC
2957 #define REASONABLE(size) (size)
2958 #else
2959 #define REASONABLE(size) (1) /* unreasonable */
2960 #endif
2961
2962 void
2963 Perl_init_stacks(pTHX)
2964 {
2965     /* start with 128-item stack and 8K cxstack */
2966     PL_curstackinfo = new_stackinfo(REASONABLE(128),
2967                                  REASONABLE(8192/sizeof(PERL_CONTEXT) - 1));
2968     PL_curstackinfo->si_type = PERLSI_MAIN;
2969     PL_curstack = PL_curstackinfo->si_stack;
2970     PL_mainstack = PL_curstack;         /* remember in case we switch stacks */
2971
2972     PL_stack_base = AvARRAY(PL_curstack);
2973     PL_stack_sp = PL_stack_base;
2974     PL_stack_max = PL_stack_base + AvMAX(PL_curstack);
2975
2976     New(50,PL_tmps_stack,REASONABLE(128),SV*);
2977     PL_tmps_floor = -1;
2978     PL_tmps_ix = -1;
2979     PL_tmps_max = REASONABLE(128);
2980
2981     New(54,PL_markstack,REASONABLE(32),I32);
2982     PL_markstack_ptr = PL_markstack;
2983     PL_markstack_max = PL_markstack + REASONABLE(32);
2984
2985     SET_MARK_OFFSET;
2986
2987     New(54,PL_scopestack,REASONABLE(32),I32);
2988     PL_scopestack_ix = 0;
2989     PL_scopestack_max = REASONABLE(32);
2990
2991     New(54,PL_savestack,REASONABLE(128),ANY);
2992     PL_savestack_ix = 0;
2993     PL_savestack_max = REASONABLE(128);
2994
2995     New(54,PL_retstack,REASONABLE(16),OP*);
2996     PL_retstack_ix = 0;
2997     PL_retstack_max = REASONABLE(16);
2998 }
2999
3000 #undef REASONABLE
3001
3002 STATIC void
3003 S_nuke_stacks(pTHX)
3004 {
3005     dTHR;
3006     while (PL_curstackinfo->si_next)
3007         PL_curstackinfo = PL_curstackinfo->si_next;
3008     while (PL_curstackinfo) {
3009         PERL_SI *p = PL_curstackinfo->si_prev;
3010         /* curstackinfo->si_stack got nuked by sv_free_arenas() */
3011         Safefree(PL_curstackinfo->si_cxstack);
3012         Safefree(PL_curstackinfo);
3013         PL_curstackinfo = p;
3014     }
3015     Safefree(PL_tmps_stack);
3016     Safefree(PL_markstack);
3017     Safefree(PL_scopestack);
3018     Safefree(PL_savestack);
3019     Safefree(PL_retstack);
3020 }
3021
3022 #ifndef PERL_OBJECT
3023 static PerlIO *tmpfp;  /* moved outside init_lexer() because of UNICOS bug */
3024 #endif
3025
3026 STATIC void
3027 S_init_lexer(pTHX)
3028 {
3029 #ifdef PERL_OBJECT
3030         PerlIO *tmpfp;
3031 #endif
3032     tmpfp = PL_rsfp;
3033     PL_rsfp = Nullfp;
3034     lex_start(PL_linestr);
3035     PL_rsfp = tmpfp;
3036     PL_subname = newSVpvn("main",4);
3037 }
3038
3039 STATIC void
3040 S_init_predump_symbols(pTHX)
3041 {
3042     dTHR;
3043     GV *tmpgv;
3044     GV *othergv;
3045     IO *io;
3046
3047     sv_setpvn(get_sv("\"", TRUE), " ", 1);
3048     PL_stdingv = gv_fetchpv("STDIN",TRUE, SVt_PVIO);
3049     GvMULTI_on(PL_stdingv);
3050     io = GvIOp(PL_stdingv);
3051     IoIFP(io) = PerlIO_stdin();
3052     tmpgv = gv_fetchpv("stdin",TRUE, SVt_PV);
3053     GvMULTI_on(tmpgv);
3054     GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io);
3055
3056     tmpgv = gv_fetchpv("STDOUT",TRUE, SVt_PVIO);
3057     GvMULTI_on(tmpgv);
3058     io = GvIOp(tmpgv);
3059     IoOFP(io) = IoIFP(io) = PerlIO_stdout();
3060     setdefout(tmpgv);
3061     tmpgv = gv_fetchpv("stdout",TRUE, SVt_PV);
3062     GvMULTI_on(tmpgv);
3063     GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io);
3064
3065     PL_stderrgv = gv_fetchpv("STDERR",TRUE, SVt_PVIO);
3066     GvMULTI_on(PL_stderrgv);
3067     io = GvIOp(PL_stderrgv);
3068     IoOFP(io) = IoIFP(io) = PerlIO_stderr();
3069     tmpgv = gv_fetchpv("stderr",TRUE, SVt_PV);
3070     GvMULTI_on(tmpgv);
3071     GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io);
3072
3073     PL_statname = NEWSV(66,0);          /* last filename we did stat on */
3074
3075     if (!PL_osname)
3076         PL_osname = savepv(OSNAME);
3077 }
3078
3079 STATIC void
3080 S_init_postdump_symbols(pTHX_ register int argc, register char **argv, register char **env)
3081 {
3082     dTHR;
3083     char *s;
3084     SV *sv;
3085     GV* tmpgv;
3086
3087     argc--,argv++;      /* skip name of script */
3088     if (PL_doswitches) {
3089         for (; argc > 0 && **argv == '-'; argc--,argv++) {
3090             if (!argv[0][1])
3091                 break;
3092             if (argv[0][1] == '-' && !argv[0][2]) {
3093                 argc--,argv++;
3094                 break;
3095             }
3096             if (s = strchr(argv[0], '=')) {
3097                 *s++ = '\0';
3098                 sv_setpv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),s);
3099             }
3100             else
3101                 sv_setiv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),1);
3102         }
3103     }
3104     PL_toptarget = NEWSV(0,0);
3105     sv_upgrade(PL_toptarget, SVt_PVFM);
3106     sv_setpvn(PL_toptarget, "", 0);
3107     PL_bodytarget = NEWSV(0,0);
3108     sv_upgrade(PL_bodytarget, SVt_PVFM);
3109     sv_setpvn(PL_bodytarget, "", 0);
3110     PL_formtarget = PL_bodytarget;
3111
3112     TAINT;
3113     if (tmpgv = gv_fetchpv("0",TRUE, SVt_PV)) {
3114         sv_setpv(GvSV(tmpgv),PL_origfilename);
3115         magicname("0", "0", 1);
3116     }
3117     if (tmpgv = gv_fetchpv("\030",TRUE, SVt_PV))
3118 #ifdef OS2
3119         sv_setpv(GvSV(tmpgv), os2_execname());
3120 #else
3121         sv_setpv(GvSV(tmpgv),PL_origargv[0]);
3122 #endif
3123     if (PL_argvgv = gv_fetchpv("ARGV",TRUE, SVt_PVAV)) {
3124         GvMULTI_on(PL_argvgv);
3125         (void)gv_AVadd(PL_argvgv);
3126         av_clear(GvAVn(PL_argvgv));
3127         for (; argc > 0; argc--,argv++) {
3128             av_push(GvAVn(PL_argvgv),newSVpv(argv[0],0));
3129         }
3130     }
3131     if (PL_envgv = gv_fetchpv("ENV",TRUE, SVt_PVHV)) {
3132         HV *hv;
3133         GvMULTI_on(PL_envgv);
3134         hv = GvHVn(PL_envgv);
3135         hv_magic(hv, PL_envgv, 'E');
3136 #if !defined( VMS) && !defined(EPOC)  /* VMS doesn't have environ array */
3137         /* Note that if the supplied env parameter is actually a copy
3138            of the global environ then it may now point to free'd memory
3139            if the environment has been modified since. To avoid this
3140            problem we treat env==NULL as meaning 'use the default'
3141         */
3142         if (!env)
3143             env = environ;
3144         if (env != environ)
3145             environ[0] = Nullch;
3146         for (; *env; env++) {
3147             if (!(s = strchr(*env,'=')))
3148                 continue;
3149             *s++ = '\0';
3150 #if defined(MSDOS)
3151             (void)strupr(*env);
3152 #endif
3153             sv = newSVpv(s--,0);
3154             (void)hv_store(hv, *env, s - *env, sv, 0);
3155             *s = '=';
3156 #if defined(__BORLANDC__) && defined(USE_WIN32_RTL_ENV)
3157             /* Sins of the RTL. See note in my_setenv(). */
3158             (void)PerlEnv_putenv(savepv(*env));
3159 #endif
3160         }
3161 #endif
3162 #ifdef DYNAMIC_ENV_FETCH
3163         HvNAME(hv) = savepv(ENV_HV_NAME);
3164 #endif
3165     }
3166     TAINT_NOT;
3167     if (tmpgv = gv_fetchpv("$",TRUE, SVt_PV))
3168         sv_setiv(GvSV(tmpgv), (IV)PerlProc_getpid());
3169 }
3170
3171 STATIC void
3172 S_init_perllib(pTHX)
3173 {
3174     char *s;
3175     if (!PL_tainting) {
3176 #ifndef VMS
3177         s = PerlEnv_getenv("PERL5LIB");
3178         if (s)
3179             incpush(s, TRUE);
3180         else
3181             incpush(PerlEnv_getenv("PERLLIB"), FALSE);
3182 #else /* VMS */
3183         /* Treat PERL5?LIB as a possible search list logical name -- the
3184          * "natural" VMS idiom for a Unix path string.  We allow each
3185          * element to be a set of |-separated directories for compatibility.
3186          */
3187         char buf[256];
3188         int idx = 0;
3189         if (my_trnlnm("PERL5LIB",buf,0))
3190             do { incpush(buf,TRUE); } while (my_trnlnm("PERL5LIB",buf,++idx));
3191         else
3192             while (my_trnlnm("PERLLIB",buf,idx++)) incpush(buf,FALSE);
3193 #endif /* VMS */
3194     }
3195
3196 /* Use the ~-expanded versions of APPLLIB (undocumented),
3197     ARCHLIB PRIVLIB SITEARCH and SITELIB
3198 */
3199 #ifdef APPLLIB_EXP
3200     incpush(APPLLIB_EXP, TRUE);
3201 #endif
3202
3203 #ifdef ARCHLIB_EXP
3204     incpush(ARCHLIB_EXP, FALSE);
3205 #endif
3206 #ifndef PRIVLIB_EXP
3207 #define PRIVLIB_EXP "/usr/local/lib/perl5:/usr/local/lib/perl"
3208 #endif
3209 #if defined(WIN32)
3210     incpush(PRIVLIB_EXP, TRUE);
3211 #else
3212     incpush(PRIVLIB_EXP, FALSE);
3213 #endif
3214
3215 #if defined(WIN32)
3216     incpush(SITELIB_EXP, TRUE); /* XXX Win32 needs inc_version_list support */
3217 #else
3218 #ifdef SITELIB_EXP
3219     {
3220         char *path = SITELIB_EXP;
3221
3222         if (path) {
3223             char buf[1024];
3224             strcpy(buf,path);
3225             if (strrchr(buf,'/'))       /* XXX Hack, Configure var needed */
3226                 *strrchr(buf,'/') = '\0';
3227             incpush(buf, TRUE);
3228         }
3229     }
3230 #endif
3231 #endif
3232 #if defined(PERL_VENDORLIB_EXP)
3233 #if defined(WIN32)
3234     incpush(PERL_VENDORLIB_EXP, TRUE);
3235 #else
3236     incpush(PERL_VENDORLIB_EXP, FALSE);
3237 #endif
3238 #endif
3239     if (!PL_tainting)
3240         incpush(".", FALSE);
3241 }
3242
3243 #if defined(DOSISH)
3244 #    define PERLLIB_SEP ';'
3245 #else
3246 #  if defined(VMS)
3247 #    define PERLLIB_SEP '|'
3248 #  else
3249 #    define PERLLIB_SEP ':'
3250 #  endif
3251 #endif
3252 #ifndef PERLLIB_MANGLE
3253 #  define PERLLIB_MANGLE(s,n) (s)
3254 #endif
3255
3256 STATIC void
3257 S_incpush(pTHX_ char *p, int addsubdirs)
3258 {
3259     SV *subdir = Nullsv;
3260
3261     if (!p)
3262         return;
3263
3264     if (addsubdirs) {
3265         subdir = sv_newmortal();
3266     }
3267
3268     /* Break at all separators */
3269     while (p && *p) {
3270         SV *libdir = NEWSV(55,0);
3271         char *s;
3272
3273         /* skip any consecutive separators */
3274         while ( *p == PERLLIB_SEP ) {
3275             /* Uncomment the next line for PATH semantics */
3276             /* av_push(GvAVn(PL_incgv), newSVpvn(".", 1)); */
3277             p++;
3278         }
3279
3280         if ( (s = strchr(p, PERLLIB_SEP)) != Nullch ) {
3281             sv_setpvn(libdir, PERLLIB_MANGLE(p, (STRLEN)(s - p)),
3282                       (STRLEN)(s - p));
3283             p = s + 1;
3284         }
3285         else {
3286             sv_setpv(libdir, PERLLIB_MANGLE(p, 0));
3287             p = Nullch; /* break out */
3288         }
3289
3290         /*
3291          * BEFORE pushing libdir onto @INC we may first push version- and
3292          * archname-specific sub-directories.
3293          */
3294         if (addsubdirs) {
3295 #ifdef PERL_INC_VERSION_LIST
3296             /* Configure terminates PERL_INC_VERSION_LIST with a NULL */
3297             const char *incverlist[] = { PERL_INC_VERSION_LIST };
3298             const char **incver;
3299 #endif
3300             struct stat tmpstatbuf;
3301 #ifdef VMS
3302             char *unix;
3303             STRLEN len;
3304
3305             if ((unix = tounixspec_ts(SvPV(libdir,len),Nullch)) != Nullch) {
3306                 len = strlen(unix);
3307                 while (unix[len-1] == '/') len--;  /* Cosmetic */
3308                 sv_usepvn(libdir,unix,len);
3309             }
3310             else
3311                 PerlIO_printf(Perl_error_log,
3312                               "Failed to unixify @INC element \"%s\"\n",
3313                               SvPV(libdir,len));
3314 #endif
3315             /* .../version/archname if -d .../version/archname */
3316             Perl_sv_setpvf(aTHX_ subdir, "%"SVf"/"PERL_FS_VER_FMT"/%s", libdir,
3317                            (int)PERL_REVISION, (int)PERL_VERSION,
3318                            (int)PERL_SUBVERSION, ARCHNAME);
3319             if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
3320                   S_ISDIR(tmpstatbuf.st_mode))
3321                 av_push(GvAVn(PL_incgv), newSVsv(subdir));
3322
3323             /* .../version if -d .../version */
3324             Perl_sv_setpvf(aTHX_ subdir, "%"SVf"/"PERL_FS_VER_FMT, libdir,
3325                            (int)PERL_REVISION, (int)PERL_VERSION,
3326                            (int)PERL_SUBVERSION);
3327             if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
3328                   S_ISDIR(tmpstatbuf.st_mode))
3329                 av_push(GvAVn(PL_incgv), newSVsv(subdir));
3330
3331             /* .../archname if -d .../archname */
3332             Perl_sv_setpvf(aTHX_ subdir, "%"SVf"/%s", libdir, ARCHNAME);
3333             if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
3334                   S_ISDIR(tmpstatbuf.st_mode))
3335                 av_push(GvAVn(PL_incgv), newSVsv(subdir));
3336
3337 #ifdef PERL_INC_VERSION_LIST
3338             for (incver = incverlist; *incver; incver++) {
3339                 /* .../xxx if -d .../xxx */
3340                 Perl_sv_setpvf(aTHX_ subdir, "%"SVf"/%s", libdir, *incver);
3341                 if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
3342                       S_ISDIR(tmpstatbuf.st_mode))
3343                     av_push(GvAVn(PL_incgv), newSVsv(subdir));
3344             }
3345 #endif
3346         }
3347
3348         /* finally push this lib directory on the end of @INC */
3349         av_push(GvAVn(PL_incgv), libdir);
3350     }
3351 }
3352
3353 #ifdef USE_THREADS
3354 STATIC struct perl_thread *
3355 S_init_main_thread(pTHX)
3356 {
3357 #if !defined(PERL_IMPLICIT_CONTEXT)
3358     struct perl_thread *thr;
3359 #endif
3360     XPV *xpv;
3361
3362     Newz(53, thr, 1, struct perl_thread);
3363     PL_curcop = &PL_compiling;
3364     thr->interp = PERL_GET_INTERP;
3365     thr->cvcache = newHV();
3366     thr->threadsv = newAV();
3367     /* thr->threadsvp is set when find_threadsv is called */
3368     thr->specific = newAV();
3369     thr->flags = THRf_R_JOINABLE;
3370     MUTEX_INIT(&thr->mutex);
3371     /* Handcraft thrsv similarly to mess_sv */
3372     New(53, PL_thrsv, 1, SV);
3373     Newz(53, xpv, 1, XPV);
3374     SvFLAGS(PL_thrsv) = SVt_PV;
3375     SvANY(PL_thrsv) = (void*)xpv;
3376     SvREFCNT(PL_thrsv) = 1 << 30;       /* practically infinite */
3377     SvPVX(PL_thrsv) = (char*)thr;
3378     SvCUR_set(PL_thrsv, sizeof(thr));
3379     SvLEN_set(PL_thrsv, sizeof(thr));
3380     *SvEND(PL_thrsv) = '\0';    /* in the trailing_nul field */
3381     thr->oursv = PL_thrsv;
3382     PL_chopset = " \n-";
3383     PL_dumpindent = 4;
3384
3385     MUTEX_LOCK(&PL_threads_mutex);
3386     PL_nthreads++;
3387     thr->tid = 0;
3388     thr->next = thr;
3389     thr->prev = thr;
3390     MUTEX_UNLOCK(&PL_threads_mutex);
3391
3392 #ifdef HAVE_THREAD_INTERN
3393     Perl_init_thread_intern(thr);
3394 #endif
3395
3396 #ifdef SET_THREAD_SELF
3397     SET_THREAD_SELF(thr);
3398 #else
3399     thr->self = pthread_self();
3400 #endif /* SET_THREAD_SELF */
3401     SET_THR(thr);
3402
3403     /*
3404      * These must come after the SET_THR because sv_setpvn does
3405      * SvTAINT and the taint fields require dTHR.
3406      */
3407     PL_toptarget = NEWSV(0,0);
3408     sv_upgrade(PL_toptarget, SVt_PVFM);
3409     sv_setpvn(PL_toptarget, "", 0);
3410     PL_bodytarget = NEWSV(0,0);
3411     sv_upgrade(PL_bodytarget, SVt_PVFM);
3412     sv_setpvn(PL_bodytarget, "", 0);
3413     PL_formtarget = PL_bodytarget;
3414     thr->errsv = newSVpvn("", 0);
3415     (void) find_threadsv("@");  /* Ensure $@ is initialised early */
3416
3417     PL_maxscream = -1;
3418     PL_regcompp = MEMBER_TO_FPTR(Perl_pregcomp);
3419     PL_regexecp = MEMBER_TO_FPTR(Perl_regexec_flags);
3420     PL_regint_start = MEMBER_TO_FPTR(Perl_re_intuit_start);
3421     PL_regint_string = MEMBER_TO_FPTR(Perl_re_intuit_string);
3422     PL_regfree = MEMBER_TO_FPTR(Perl_pregfree);
3423     PL_regindent = 0;
3424     PL_reginterp_cnt = 0;
3425
3426     return thr;
3427 }
3428 #endif /* USE_THREADS */
3429
3430 void
3431 Perl_call_list(pTHX_ I32 oldscope, AV *paramList)
3432 {
3433     dTHR;
3434     SV *atsv;
3435     line_t oldline = CopLINE(PL_curcop);
3436     CV *cv;
3437     STRLEN len;
3438     int ret;
3439     dJMPENV;
3440
3441     while (AvFILL(paramList) >= 0) {
3442         cv = (CV*)av_shift(paramList);
3443         SAVEFREESV(cv);
3444 #ifdef PERL_FLEXIBLE_EXCEPTIONS
3445         CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_vcall_list_body), cv);
3446 #else
3447         JMPENV_PUSH(ret);
3448 #endif
3449         switch (ret) {
3450         case 0:
3451 #ifndef PERL_FLEXIBLE_EXCEPTIONS
3452             call_list_body(cv);
3453 #endif
3454             atsv = ERRSV;
3455             (void)SvPV(atsv, len);
3456             if (len) {
3457                 STRLEN n_a;
3458                 PL_curcop = &PL_compiling;
3459                 CopLINE_set(PL_curcop, oldline);
3460                 if (paramList == PL_beginav)
3461                     sv_catpv(atsv, "BEGIN failed--compilation aborted");
3462                 else
3463                     Perl_sv_catpvf(aTHX_ atsv,
3464                                    "%s failed--call queue aborted",
3465                                    paramList == PL_checkav ? "CHECK"
3466                                    : paramList == PL_initav ? "INIT"
3467                                    : "END");
3468                 while (PL_scopestack_ix > oldscope)
3469                     LEAVE;
3470                 JMPENV_POP;
3471                 Perl_croak(aTHX_ "%s", SvPVx(atsv, n_a));
3472             }
3473             break;
3474         case 1:
3475             STATUS_ALL_FAILURE;
3476             /* FALL THROUGH */
3477         case 2:
3478             /* my_exit() was called */
3479             while (PL_scopestack_ix > oldscope)
3480                 LEAVE;
3481             FREETMPS;
3482             PL_curstash = PL_defstash;
3483             PL_curcop = &PL_compiling;
3484             CopLINE_set(PL_curcop, oldline);
3485             JMPENV_POP;
3486             if (PL_statusvalue && !(PL_exit_flags & PERL_EXIT_EXPECTED)) {
3487                 if (paramList == PL_beginav)
3488                     Perl_croak(aTHX_ "BEGIN failed--compilation aborted");
3489                 else
3490                     Perl_croak(aTHX_ "%s failed--call queue aborted",
3491                                paramList == PL_checkav ? "CHECK"
3492                                : paramList == PL_initav ? "INIT"
3493                                : "END");
3494             }
3495             my_exit_jump();
3496             /* NOTREACHED */
3497         case 3:
3498             if (PL_restartop) {
3499                 PL_curcop = &PL_compiling;
3500                 CopLINE_set(PL_curcop, oldline);
3501                 JMPENV_JUMP(3);
3502             }
3503             PerlIO_printf(Perl_error_log, "panic: restartop\n");
3504             FREETMPS;
3505             break;
3506         }
3507         JMPENV_POP;
3508     }
3509 }
3510
3511 #ifdef PERL_FLEXIBLE_EXCEPTIONS
3512 STATIC void *
3513 S_vcall_list_body(pTHX_ va_list args)
3514 {
3515     CV *cv = va_arg(args, CV*);
3516     return call_list_body(cv);
3517 }
3518 #endif
3519
3520 STATIC void *
3521 S_call_list_body(pTHX_ CV *cv)
3522 {
3523     PUSHMARK(PL_stack_sp);
3524     call_sv((SV*)cv, G_EVAL|G_DISCARD);
3525     return NULL;
3526 }
3527
3528 void
3529 Perl_my_exit(pTHX_ U32 status)
3530 {
3531     dTHR;
3532
3533     DEBUG_S(PerlIO_printf(Perl_debug_log, "my_exit: thread %p, status %lu\n",
3534                           thr, (unsigned long) status));
3535     switch (status) {
3536     case 0:
3537         STATUS_ALL_SUCCESS;
3538         break;
3539     case 1:
3540         STATUS_ALL_FAILURE;
3541         break;
3542     default:
3543         STATUS_NATIVE_SET(status);
3544         break;
3545     }
3546     my_exit_jump();
3547 }
3548
3549 void
3550 Perl_my_failure_exit(pTHX)
3551 {
3552 #ifdef VMS
3553     if (vaxc$errno & 1) {
3554         if (STATUS_NATIVE & 1)          /* fortuitiously includes "-1" */
3555             STATUS_NATIVE_SET(44);
3556     }
3557     else {
3558         if (!vaxc$errno && errno)       /* unlikely */
3559             STATUS_NATIVE_SET(44);
3560         else
3561             STATUS_NATIVE_SET(vaxc$errno);
3562     }
3563 #else
3564     int exitstatus;
3565     if (errno & 255)
3566         STATUS_POSIX_SET(errno);
3567     else {
3568         exitstatus = STATUS_POSIX >> 8;
3569         if (exitstatus & 255)
3570             STATUS_POSIX_SET(exitstatus);
3571         else
3572             STATUS_POSIX_SET(255);
3573     }
3574 #endif
3575     my_exit_jump();
3576 }
3577
3578 STATIC void
3579 S_my_exit_jump(pTHX)
3580 {
3581     dTHR;
3582     register PERL_CONTEXT *cx;
3583     I32 gimme;
3584     SV **newsp;
3585
3586     if (PL_e_script) {
3587         SvREFCNT_dec(PL_e_script);
3588         PL_e_script = Nullsv;
3589     }
3590
3591     POPSTACK_TO(PL_mainstack);
3592     if (cxstack_ix >= 0) {
3593         if (cxstack_ix > 0)
3594             dounwind(0);
3595         POPBLOCK(cx,PL_curpm);
3596         LEAVE;
3597     }
3598
3599     JMPENV_JUMP(2);
3600 }
3601
3602 #ifdef PERL_OBJECT
3603 #include "XSUB.h"
3604 #endif
3605
3606 static I32
3607 read_e_script(pTHXo_ int idx, SV *buf_sv, int maxlen)
3608 {
3609     char *p, *nl;
3610     p  = SvPVX(PL_e_script);
3611     nl = strchr(p, '\n');
3612     nl = (nl) ? nl+1 : SvEND(PL_e_script);
3613     if (nl-p == 0) {
3614         filter_del(read_e_script);
3615         return 0;
3616     }
3617     sv_catpvn(buf_sv, p, nl-p);
3618     sv_chop(PL_e_script, nl);
3619     return 1;
3620 }