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 "-x[directory]   strip off text before #!perl line and perhaps cd to directory",
1911 "\n",
1912 NULL
1913 };
1914     char **p = usage_msg;
1915
1916     printf("\nUsage: %s [switches] [--] [programfile] [arguments]", name);
1917     while (*p)
1918         printf("\n  %s", *p++);
1919 }
1920
1921 /* This routine handles any switches that can be given during run */
1922
1923 char *
1924 Perl_moreswitches(pTHX_ char *s)
1925 {
1926     I32 numlen;
1927     U32 rschar;
1928
1929     switch (*s) {
1930     case '0':
1931     {
1932         dTHR;
1933         rschar = (U32)scan_oct(s, 4, &numlen);
1934         SvREFCNT_dec(PL_nrs);
1935         if (rschar & ~((U8)~0))
1936             PL_nrs = &PL_sv_undef;
1937         else if (!rschar && numlen >= 2)
1938             PL_nrs = newSVpvn("", 0);
1939         else {
1940             char ch = rschar;
1941             PL_nrs = newSVpvn(&ch, 1);
1942         }
1943         return s + numlen;
1944     }
1945     case 'C':
1946         PL_widesyscalls = TRUE;
1947         s++;
1948         return s;
1949     case 'F':
1950         PL_minus_F = TRUE;
1951         PL_splitstr = savepv(s + 1);
1952         s += strlen(s);
1953         return s;
1954     case 'a':
1955         PL_minus_a = TRUE;
1956         s++;
1957         return s;
1958     case 'c':
1959         PL_minus_c = TRUE;
1960         s++;
1961         return s;
1962     case 'd':
1963         forbid_setid("-d");
1964         s++;
1965         if (*s == ':' || *s == '=')  {
1966             my_setenv("PERL5DB", Perl_form(aTHX_ "use Devel::%s;", ++s));
1967             s += strlen(s);
1968         }
1969         if (!PL_perldb) {
1970             PL_perldb = PERLDB_ALL;
1971             init_debugger();
1972         }
1973         return s;
1974     case 'D':
1975     {
1976 #ifdef DEBUGGING
1977         forbid_setid("-D");
1978         if (isALPHA(s[1])) {
1979             static char debopts[] = "psltocPmfrxuLHXDS";
1980             char *d;
1981
1982             for (s++; *s && (d = strchr(debopts,*s)); s++)
1983                 PL_debug |= 1 << (d - debopts);
1984         }
1985         else {
1986             PL_debug = atoi(s+1);
1987             for (s++; isDIGIT(*s); s++) ;
1988         }
1989         PL_debug |= 0x80000000;
1990 #else
1991         dTHR;
1992         if (ckWARN_d(WARN_DEBUGGING))
1993             Perl_warner(aTHX_ WARN_DEBUGGING,
1994                    "Recompile perl with -DDEBUGGING to use -D switch\n");
1995         for (s++; isALNUM(*s); s++) ;
1996 #endif
1997         /*SUPPRESS 530*/
1998         return s;
1999     }
2000     case 'h':
2001         usage(PL_origargv[0]);
2002         PerlProc_exit(0);
2003     case 'i':
2004         if (PL_inplace)
2005             Safefree(PL_inplace);
2006         PL_inplace = savepv(s+1);
2007         /*SUPPRESS 530*/
2008         for (s = PL_inplace; *s && !isSPACE(*s); s++) ;
2009         if (*s) {
2010             *s++ = '\0';
2011             if (*s == '-')      /* Additional switches on #! line. */
2012                 s++;
2013         }
2014         return s;
2015     case 'I':   /* -I handled both here and in parse_perl() */
2016         forbid_setid("-I");
2017         ++s;
2018         while (*s && isSPACE(*s))
2019             ++s;
2020         if (*s) {
2021             char *e, *p;
2022             p = s;
2023             /* ignore trailing spaces (possibly followed by other switches) */
2024             do {
2025                 for (e = p; *e && !isSPACE(*e); e++) ;
2026                 p = e;
2027                 while (isSPACE(*p))
2028                     p++;
2029             } while (*p && *p != '-');
2030             e = savepvn(s, e-s);
2031             incpush(e, TRUE);
2032             Safefree(e);
2033             s = p;
2034             if (*s == '-')
2035                 s++;
2036         }
2037         else
2038             Perl_croak(aTHX_ "No directory specified for -I");
2039         return s;
2040     case 'l':
2041         PL_minus_l = TRUE;
2042         s++;
2043         if (PL_ors)
2044             Safefree(PL_ors);
2045         if (isDIGIT(*s)) {
2046             PL_ors = savepv("\n");
2047             PL_orslen = 1;
2048             *PL_ors = (char)scan_oct(s, 3 + (*s == '0'), &numlen);
2049             s += numlen;
2050         }
2051         else {
2052             dTHR;
2053             if (RsPARA(PL_nrs)) {
2054                 PL_ors = "\n\n";
2055                 PL_orslen = 2;
2056             }
2057             else
2058                 PL_ors = SvPV(PL_nrs, PL_orslen);
2059             PL_ors = savepvn(PL_ors, PL_orslen);
2060         }
2061         return s;
2062     case 'M':
2063         forbid_setid("-M");     /* XXX ? */
2064         /* FALL THROUGH */
2065     case 'm':
2066         forbid_setid("-m");     /* XXX ? */
2067         if (*++s) {
2068             char *start;
2069             SV *sv;
2070             char *use = "use ";
2071             /* -M-foo == 'no foo'       */
2072             if (*s == '-') { use = "no "; ++s; }
2073             sv = newSVpv(use,0);
2074             start = s;
2075             /* We allow -M'Module qw(Foo Bar)'  */
2076             while(isALNUM(*s) || *s==':') ++s;
2077             if (*s != '=') {
2078                 sv_catpv(sv, start);
2079                 if (*(start-1) == 'm') {
2080                     if (*s != '\0')
2081                         Perl_croak(aTHX_ "Can't use '%c' after -mname", *s);
2082                     sv_catpv( sv, " ()");
2083                 }
2084             } else {
2085                 sv_catpvn(sv, start, s-start);
2086                 sv_catpv(sv, " split(/,/,q{");
2087                 sv_catpv(sv, ++s);
2088                 sv_catpv(sv,    "})");
2089             }
2090             s += strlen(s);
2091             if (!PL_preambleav)
2092                 PL_preambleav = newAV();
2093             av_push(PL_preambleav, sv);
2094         }
2095         else
2096             Perl_croak(aTHX_ "No space allowed after -%c", *(s-1));
2097         return s;
2098     case 'n':
2099         PL_minus_n = TRUE;
2100         s++;
2101         return s;
2102     case 'p':
2103         PL_minus_p = TRUE;
2104         s++;
2105         return s;
2106     case 's':
2107         forbid_setid("-s");
2108         PL_doswitches = TRUE;
2109         s++;
2110         return s;
2111     case 'T':
2112         if (!PL_tainting)
2113             Perl_croak(aTHX_ "Too late for \"-T\" option");
2114         s++;
2115         return s;
2116     case 'u':
2117         PL_do_undump = TRUE;
2118         s++;
2119         return s;
2120     case 'U':
2121         PL_unsafe = TRUE;
2122         s++;
2123         return s;
2124     case 'v':
2125         printf(Perl_form(aTHX_ "\nThis is perl, v%vd built for %s",
2126                          PL_patchlevel, ARCHNAME));
2127 #if defined(LOCAL_PATCH_COUNT)
2128         if (LOCAL_PATCH_COUNT > 0)
2129             printf("\n(with %d registered patch%s, see perl -V for more detail)",
2130                 (int)LOCAL_PATCH_COUNT, (LOCAL_PATCH_COUNT!=1) ? "es" : "");
2131 #endif
2132
2133         printf("\n\nCopyright 1987-2000, Larry Wall\n");
2134 #ifdef MSDOS
2135         printf("\nMS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n");
2136 #endif
2137 #ifdef DJGPP
2138         printf("djgpp v2 port (jpl5003c) by Hirofumi Watanabe, 1996\n");
2139         printf("djgpp v2 port (perl5004+) by Laszlo Molnar, 1997-1999\n");
2140 #endif
2141 #ifdef OS2
2142         printf("\n\nOS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n"
2143             "Version 5 port Copyright (c) 1994-1999, Andreas Kaiser, Ilya Zakharevich\n");
2144 #endif
2145 #ifdef atarist
2146         printf("atariST series port, ++jrb  bammi@cadence.com\n");
2147 #endif
2148 #ifdef __BEOS__
2149         printf("BeOS port Copyright Tom Spindler, 1997-1999\n");
2150 #endif
2151 #ifdef MPE
2152         printf("MPE/iX port Copyright by Mark Klein and Mark Bixby, 1996-1999\n");
2153 #endif
2154 #ifdef OEMVS
2155         printf("MVS (OS390) port by Mortice Kern Systems, 1997-1999\n");
2156 #endif
2157 #ifdef __VOS__
2158         printf("Stratus VOS port by Paul_Green@stratus.com, 1997-1999\n");
2159 #endif
2160 #ifdef __OPEN_VM
2161         printf("VM/ESA port by Neale Ferguson, 1998-1999\n");
2162 #endif
2163 #ifdef POSIX_BC
2164         printf("BS2000 (POSIX) port by Start Amadeus GmbH, 1998-1999\n");
2165 #endif
2166 #ifdef __MINT__
2167         printf("MiNT port by Guido Flohr, 1997-1999\n");
2168 #endif
2169 #ifdef EPOC
2170         printf("EPOC port by Olaf Flebbe, 1999-2000\n");
2171 #endif
2172 #ifdef BINARY_BUILD_NOTICE
2173         BINARY_BUILD_NOTICE;
2174 #endif
2175         printf("\n\
2176 Perl may be copied only under the terms of either the Artistic License or the\n\
2177 GNU General Public License, which may be found in the Perl 5.0 source kit.\n\n\
2178 Complete documentation for Perl, including FAQ lists, should be found on\n\
2179 this system using `man perl' or `perldoc perl'.  If you have access to the\n\
2180 Internet, point your browser at http://www.perl.com/, the Perl Home Page.\n\n");
2181         PerlProc_exit(0);
2182     case 'w':
2183         if (! (PL_dowarn & G_WARN_ALL_MASK))
2184             PL_dowarn |= G_WARN_ON;
2185         s++;
2186         return s;
2187     case 'W':
2188         PL_dowarn = G_WARN_ALL_ON|G_WARN_ON;
2189         PL_compiling.cop_warnings = WARN_ALL ;
2190         s++;
2191         return s;
2192     case 'X':
2193         PL_dowarn = G_WARN_ALL_OFF;
2194         PL_compiling.cop_warnings = WARN_NONE ;
2195         s++;
2196         return s;
2197     case '*':
2198     case ' ':
2199         if (s[1] == '-')        /* Additional switches on #! line. */
2200             return s+2;
2201         break;
2202     case '-':
2203     case 0:
2204 #if defined(WIN32) || !defined(PERL_STRICT_CR)
2205     case '\r':
2206 #endif
2207     case '\n':
2208     case '\t':
2209         break;
2210 #ifdef ALTERNATE_SHEBANG
2211     case 'S':                   /* OS/2 needs -S on "extproc" line. */
2212         break;
2213 #endif
2214     case 'P':
2215         if (PL_preprocess)
2216             return s+1;
2217         /* FALL THROUGH */
2218     default:
2219         Perl_croak(aTHX_ "Can't emulate -%.1s on #! line",s);
2220     }
2221     return Nullch;
2222 }
2223
2224 /* compliments of Tom Christiansen */
2225
2226 /* unexec() can be found in the Gnu emacs distribution */
2227 /* Known to work with -DUNEXEC and using unexelf.c from GNU emacs-20.2 */
2228
2229 void
2230 Perl_my_unexec(pTHX)
2231 {
2232 #ifdef UNEXEC
2233     SV*    prog;
2234     SV*    file;
2235     int    status = 1;
2236     extern int etext;
2237
2238     prog = newSVpv(BIN_EXP, 0);
2239     sv_catpv(prog, "/perl");
2240     file = newSVpv(PL_origfilename, 0);
2241     sv_catpv(file, ".perldump");
2242
2243     unexec(SvPVX(file), SvPVX(prog), &etext, sbrk(0), 0);
2244     /* unexec prints msg to stderr in case of failure */
2245     PerlProc_exit(status);
2246 #else
2247 #  ifdef VMS
2248 #    include <lib$routines.h>
2249      lib$signal(SS$_DEBUG);  /* ssdef.h #included from vmsish.h */
2250 #  else
2251     ABORT();            /* for use with undump */
2252 #  endif
2253 #endif
2254 }
2255
2256 /* initialize curinterp */
2257 STATIC void
2258 S_init_interp(pTHX)
2259 {
2260
2261 #ifdef PERL_OBJECT              /* XXX kludge */
2262 #define I_REINIT \
2263   STMT_START {                          \
2264     PL_chopset          = " \n-";       \
2265     PL_copline          = NOLINE;       \
2266     PL_curcop           = &PL_compiling;\
2267     PL_curcopdb         = NULL;         \
2268     PL_dbargs           = 0;            \
2269     PL_dumpindent       = 4;            \
2270     PL_laststatval      = -1;           \
2271     PL_laststype        = OP_STAT;      \
2272     PL_maxscream        = -1;           \
2273     PL_maxsysfd         = MAXSYSFD;     \
2274     PL_statname         = Nullsv;       \
2275     PL_tmps_floor       = -1;           \
2276     PL_tmps_ix          = -1;           \
2277     PL_op_mask          = NULL;         \
2278     PL_laststatval      = -1;           \
2279     PL_laststype        = OP_STAT;      \
2280     PL_mess_sv          = Nullsv;       \
2281     PL_splitstr         = " ";          \
2282     PL_generation       = 100;          \
2283     PL_exitlist         = NULL;         \
2284     PL_exitlistlen      = 0;            \
2285     PL_regindent        = 0;            \
2286     PL_in_clean_objs    = FALSE;        \
2287     PL_in_clean_all     = FALSE;        \
2288     PL_profiledata      = NULL;         \
2289     PL_rsfp             = Nullfp;       \
2290     PL_rsfp_filters     = Nullav;       \
2291     PL_dirty            = FALSE;        \
2292   } STMT_END
2293     I_REINIT;
2294 #else
2295 #  ifdef MULTIPLICITY
2296 #    define PERLVAR(var,type)
2297 #    define PERLVARA(var,n,type)
2298 #    if defined(PERL_IMPLICIT_CONTEXT)
2299 #      if defined(USE_THREADS)
2300 #        define PERLVARI(var,type,init)         PERL_GET_INTERP->var = init;
2301 #        define PERLVARIC(var,type,init)        PERL_GET_INTERP->var = init;
2302 #      else /* !USE_THREADS */
2303 #        define PERLVARI(var,type,init)         aTHX->var = init;
2304 #        define PERLVARIC(var,type,init)        aTHX->var = init;
2305 #      endif /* USE_THREADS */
2306 #    else
2307 #      define PERLVARI(var,type,init)   PERL_GET_INTERP->var = init;
2308 #      define PERLVARIC(var,type,init)  PERL_GET_INTERP->var = init;
2309 #    endif
2310 #    include "intrpvar.h"
2311 #    ifndef USE_THREADS
2312 #      include "thrdvar.h"
2313 #    endif
2314 #    undef PERLVAR
2315 #    undef PERLVARA
2316 #    undef PERLVARI
2317 #    undef PERLVARIC
2318 #  else
2319 #    define PERLVAR(var,type)
2320 #    define PERLVARA(var,n,type)
2321 #    define PERLVARI(var,type,init)     PL_##var = init;
2322 #    define PERLVARIC(var,type,init)    PL_##var = init;
2323 #    include "intrpvar.h"
2324 #    ifndef USE_THREADS
2325 #      include "thrdvar.h"
2326 #    endif
2327 #    undef PERLVAR
2328 #    undef PERLVARA
2329 #    undef PERLVARI
2330 #    undef PERLVARIC
2331 #  endif
2332 #endif
2333
2334 }
2335
2336 STATIC void
2337 S_init_main_stash(pTHX)
2338 {
2339     dTHR;
2340     GV *gv;
2341
2342     /* Note that strtab is a rather special HV.  Assumptions are made
2343        about not iterating on it, and not adding tie magic to it.
2344        It is properly deallocated in perl_destruct() */
2345     PL_strtab = newHV();
2346 #ifdef USE_THREADS
2347     MUTEX_INIT(&PL_strtab_mutex);
2348 #endif
2349     HvSHAREKEYS_off(PL_strtab);                 /* mandatory */
2350     hv_ksplit(PL_strtab, 512);
2351
2352     PL_curstash = PL_defstash = newHV();
2353     PL_curstname = newSVpvn("main",4);
2354     gv = gv_fetchpv("main::",TRUE, SVt_PVHV);
2355     SvREFCNT_dec(GvHV(gv));
2356     GvHV(gv) = (HV*)SvREFCNT_inc(PL_defstash);
2357     SvREADONLY_on(gv);
2358     HvNAME(PL_defstash) = savepv("main");
2359     PL_incgv = gv_HVadd(gv_AVadd(gv_fetchpv("INC",TRUE, SVt_PVAV)));
2360     GvMULTI_on(PL_incgv);
2361     PL_hintgv = gv_fetchpv("\010",TRUE, SVt_PV); /* ^H */
2362     GvMULTI_on(PL_hintgv);
2363     PL_defgv = gv_fetchpv("_",TRUE, SVt_PVAV);
2364     PL_errgv = gv_HVadd(gv_fetchpv("@", TRUE, SVt_PV));
2365     GvMULTI_on(PL_errgv);
2366     PL_replgv = gv_fetchpv("\022", TRUE, SVt_PV); /* ^R */
2367     GvMULTI_on(PL_replgv);
2368     (void)Perl_form(aTHX_ "%240s","");  /* Preallocate temp - for immediate signals. */
2369     sv_grow(ERRSV, 240);        /* Preallocate - for immediate signals. */
2370     sv_setpvn(ERRSV, "", 0);
2371     PL_curstash = PL_defstash;
2372     CopSTASH_set(&PL_compiling, PL_defstash);
2373     PL_debstash = GvHV(gv_fetchpv("DB::", GV_ADDMULTI, SVt_PVHV));
2374     PL_globalstash = GvHV(gv_fetchpv("CORE::GLOBAL::", GV_ADDMULTI, SVt_PVHV));
2375     /* We must init $/ before switches are processed. */
2376     sv_setpvn(get_sv("/", TRUE), "\n", 1);
2377 }
2378
2379 STATIC void
2380 S_open_script(pTHX_ char *scriptname, bool dosearch, SV *sv, int *fdscript)
2381 {
2382     dTHR;
2383     register char *s;
2384
2385     *fdscript = -1;
2386
2387     if (PL_e_script) {
2388         PL_origfilename = savepv("-e");
2389     }
2390     else {
2391         /* if find_script() returns, it returns a malloc()-ed value */
2392         PL_origfilename = scriptname = find_script(scriptname, dosearch, NULL, 1);
2393
2394         if (strnEQ(scriptname, "/dev/fd/", 8) && isDIGIT(scriptname[8]) ) {
2395             char *s = scriptname + 8;
2396             *fdscript = atoi(s);
2397             while (isDIGIT(*s))
2398                 s++;
2399             if (*s) {
2400                 scriptname = savepv(s + 1);
2401                 Safefree(PL_origfilename);
2402                 PL_origfilename = scriptname;
2403             }
2404         }
2405     }
2406
2407     CopFILE_set(PL_curcop, PL_origfilename);
2408     if (strEQ(PL_origfilename,"-"))
2409         scriptname = "";
2410     if (*fdscript >= 0) {
2411         PL_rsfp = PerlIO_fdopen(*fdscript,PERL_SCRIPT_MODE);
2412 #if defined(HAS_FCNTL) && defined(F_SETFD)
2413         if (PL_rsfp)
2414             fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,1);  /* ensure close-on-exec */
2415 #endif
2416     }
2417     else if (PL_preprocess) {
2418         char *cpp_cfg = CPPSTDIN;
2419         SV *cpp = newSVpvn("",0);
2420         SV *cmd = NEWSV(0,0);
2421
2422         if (strEQ(cpp_cfg, "cppstdin"))
2423             Perl_sv_catpvf(aTHX_ cpp, "%s/", BIN_EXP);
2424         sv_catpv(cpp, cpp_cfg);
2425
2426         sv_catpvn(sv, "-I", 2);
2427         sv_catpv(sv,PRIVLIB_EXP);
2428
2429 #ifdef MSDOS
2430         Perl_sv_setpvf(aTHX_ cmd, "\
2431 sed %s -e \"/^[^#]/b\" \
2432  -e \"/^#[      ]*include[      ]/b\" \
2433  -e \"/^#[      ]*define[       ]/b\" \
2434  -e \"/^#[      ]*if[   ]/b\" \
2435  -e \"/^#[      ]*ifdef[        ]/b\" \
2436  -e \"/^#[      ]*ifndef[       ]/b\" \
2437  -e \"/^#[      ]*else/b\" \
2438  -e \"/^#[      ]*elif[         ]/b\" \
2439  -e \"/^#[      ]*undef[        ]/b\" \
2440  -e \"/^#[      ]*endif/b\" \
2441  -e \"s/^#.*//\" \
2442  %s | %"SVf" -C %"SVf" %s",
2443           (PL_doextract ? "-e \"1,/^#/d\n\"" : ""),
2444 #else
2445 #  ifdef __OPEN_VM
2446         Perl_sv_setpvf(aTHX_ cmd, "\
2447 %s %s -e '/^[^#]/b' \
2448  -e '/^#[       ]*include[      ]/b' \
2449  -e '/^#[       ]*define[       ]/b' \
2450  -e '/^#[       ]*if[   ]/b' \
2451  -e '/^#[       ]*ifdef[        ]/b' \
2452  -e '/^#[       ]*ifndef[       ]/b' \
2453  -e '/^#[       ]*else/b' \
2454  -e '/^#[       ]*elif[         ]/b' \
2455  -e '/^#[       ]*undef[        ]/b' \
2456  -e '/^#[       ]*endif/b' \
2457  -e 's/^[       ]*#.*//' \
2458  %s | %"SVf" %"SVf" %s",
2459 #  else
2460         Perl_sv_setpvf(aTHX_ cmd, "\
2461 %s %s -e '/^[^#]/b' \
2462  -e '/^#[       ]*include[      ]/b' \
2463  -e '/^#[       ]*define[       ]/b' \
2464  -e '/^#[       ]*if[   ]/b' \
2465  -e '/^#[       ]*ifdef[        ]/b' \
2466  -e '/^#[       ]*ifndef[       ]/b' \
2467  -e '/^#[       ]*else/b' \
2468  -e '/^#[       ]*elif[         ]/b' \
2469  -e '/^#[       ]*undef[        ]/b' \
2470  -e '/^#[       ]*endif/b' \
2471  -e 's/^[       ]*#.*//' \
2472  %s | %"SVf" -C %"SVf" %s",
2473 #  endif
2474 #ifdef LOC_SED
2475           LOC_SED,
2476 #else
2477           "sed",
2478 #endif
2479           (PL_doextract ? "-e '1,/^#/d\n'" : ""),
2480 #endif
2481           scriptname, cpp, sv, CPPMINUS);
2482         PL_doextract = FALSE;
2483 #ifdef IAMSUID                          /* actually, this is caught earlier */
2484         if (PL_euid != PL_uid && !PL_euid) {    /* if running suidperl */
2485 #ifdef HAS_SETEUID
2486             (void)seteuid(PL_uid);              /* musn't stay setuid root */
2487 #else
2488 #ifdef HAS_SETREUID
2489             (void)setreuid((Uid_t)-1, PL_uid);
2490 #else
2491 #ifdef HAS_SETRESUID
2492             (void)setresuid((Uid_t)-1, PL_uid, (Uid_t)-1);
2493 #else
2494             PerlProc_setuid(PL_uid);
2495 #endif
2496 #endif
2497 #endif
2498             if (PerlProc_geteuid() != PL_uid)
2499                 Perl_croak(aTHX_ "Can't do seteuid!\n");
2500         }
2501 #endif /* IAMSUID */
2502         PL_rsfp = PerlProc_popen(SvPVX(cmd), "r");
2503         SvREFCNT_dec(cmd);
2504         SvREFCNT_dec(cpp);
2505     }
2506     else if (!*scriptname) {
2507         forbid_setid("program input from stdin");
2508         PL_rsfp = PerlIO_stdin();
2509     }
2510     else {
2511         PL_rsfp = PerlIO_open(scriptname,PERL_SCRIPT_MODE);
2512 #if defined(HAS_FCNTL) && defined(F_SETFD)
2513         if (PL_rsfp)
2514             fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,1);  /* ensure close-on-exec */
2515 #endif
2516     }
2517     if (!PL_rsfp) {
2518 #ifdef DOSUID
2519 #ifndef IAMSUID         /* in case script is not readable before setuid */
2520         if (PL_euid &&
2521             PerlLIO_stat(CopFILE(PL_curcop),&PL_statbuf) >= 0 &&
2522             PL_statbuf.st_mode & (S_ISUID|S_ISGID))
2523         {
2524             /* try again */
2525             PerlProc_execv(Perl_form(aTHX_ "%s/sperl"PERL_FS_VER_FMT, BIN_EXP,
2526                                      (int)PERL_REVISION, (int)PERL_VERSION,
2527                                      (int)PERL_SUBVERSION), PL_origargv);
2528             Perl_croak(aTHX_ "Can't do setuid\n");
2529         }
2530 #endif
2531 #endif
2532         Perl_croak(aTHX_ "Can't open perl script \"%s\": %s\n",
2533                    CopFILE(PL_curcop), Strerror(errno));
2534     }
2535 }
2536
2537 /* Mention
2538  * I_SYSSTATVFS HAS_FSTATVFS
2539  * I_SYSMOUNT
2540  * I_STATFS     HAS_FSTATFS
2541  * I_MNTENT     HAS_GETMNTENT   HAS_HASMNTOPT
2542  * here so that metaconfig picks them up. */
2543
2544 #ifdef IAMSUID
2545 STATIC int
2546 S_fd_on_nosuid_fs(pTHX_ int fd)
2547 {
2548     int check_okay = 0; /* able to do all the required sys/libcalls */
2549     int on_nosuid  = 0; /* the fd is on a nosuid fs */
2550 /*
2551  * Preferred order: fstatvfs(), fstatfs(), ustat()+getmnt(), getmntent().
2552  * fstatvfs() is UNIX98.
2553  * fstatfs() is 4.3 BSD.
2554  * ustat()+getmnt() is pre-4.3 BSD.
2555  * getmntent() is O(number-of-mounted-filesystems) and can hang on
2556  * an irrelevant filesystem while trying to reach the right one.
2557  */
2558
2559 #   ifdef HAS_FSTATVFS
2560     struct statvfs stfs;
2561     check_okay = fstatvfs(fd, &stfs) == 0;
2562     on_nosuid  = check_okay && (stfs.f_flag  & ST_NOSUID);
2563 #   else
2564 #       ifdef PERL_MOUNT_NOSUID
2565 #           if defined(HAS_FSTATFS) && \
2566                defined(HAS_STRUCT_STATFS) && \
2567                defined(HAS_STRUCT_STATFS_F_FLAGS)
2568     struct statfs  stfs;
2569     check_okay = fstatfs(fd, &stfs)  == 0;
2570     on_nosuid  = check_okay && (stfs.f_flags & PERL_MOUNT_NOSUID);
2571 #           else
2572 #               if defined(HAS_FSTAT) && \
2573                    defined(HAS_USTAT) && \
2574                    defined(HAS_GETMNT) && \
2575                    defined(HAS_STRUCT_FS_DATA) && \
2576                    defined(NOSTAT_ONE)
2577     struct stat fdst;
2578     if (fstat(fd, &fdst) == 0) {
2579         struct ustat us;
2580         if (ustat(fdst.st_dev, &us) == 0) {
2581             struct fs_data fsd;
2582             /* NOSTAT_ONE here because we're not examining fields which
2583              * vary between that case and STAT_ONE. */
2584             if (getmnt((int*)0, &fsd, (int)0, NOSTAT_ONE, us.f_fname) == 0) {
2585                 size_t cmplen = sizeof(us.f_fname);
2586                 if (sizeof(fsd.fd_req.path) < cmplen)
2587                     cmplen = sizeof(fsd.fd_req.path);
2588                 if (strnEQ(fsd.fd_req.path, us.f_fname, cmplen) &&
2589                     fdst.st_dev == fsd.fd_req.dev) {
2590                         check_okay = 1;
2591                         on_nosuid = fsd.fd_req.flags & PERL_MOUNT_NOSUID;
2592                     }
2593                 }
2594             }
2595         }
2596     }
2597 #               endif /* fstat+ustat+getmnt */
2598 #           endif /* fstatfs */
2599 #       else
2600 #           if defined(HAS_GETMNTENT) && \
2601                defined(HAS_HASMNTOPT) && \
2602                defined(MNTOPT_NOSUID)
2603     FILE                *mtab = fopen("/etc/mtab", "r");
2604     struct mntent       *entry;
2605     struct stat         stb, fsb;
2606
2607     if (mtab && (fstat(fd, &stb) == 0)) {
2608         while (entry = getmntent(mtab)) {
2609             if (stat(entry->mnt_dir, &fsb) == 0
2610                 && fsb.st_dev == stb.st_dev)
2611             {
2612                 /* found the filesystem */
2613                 check_okay = 1;
2614                 if (hasmntopt(entry, MNTOPT_NOSUID))
2615                     on_nosuid = 1;
2616                 break;
2617             } /* A single fs may well fail its stat(). */
2618         }
2619     }
2620     if (mtab)
2621         fclose(mtab);
2622 #           endif /* getmntent+hasmntopt */
2623 #       endif /* PERL_MOUNT_NOSUID: fstatfs or fstat+ustat+statfs */
2624 #   endif /* statvfs */
2625
2626     if (!check_okay)
2627         Perl_croak(aTHX_ "Can't check filesystem of script \"%s\" for nosuid", PL_origfilename);
2628     return on_nosuid;
2629 }
2630 #endif /* IAMSUID */
2631
2632 STATIC void
2633 S_validate_suid(pTHX_ char *validarg, char *scriptname, int fdscript)
2634 {
2635     int which;
2636
2637     /* do we need to emulate setuid on scripts? */
2638
2639     /* This code is for those BSD systems that have setuid #! scripts disabled
2640      * in the kernel because of a security problem.  Merely defining DOSUID
2641      * in perl will not fix that problem, but if you have disabled setuid
2642      * scripts in the kernel, this will attempt to emulate setuid and setgid
2643      * on scripts that have those now-otherwise-useless bits set.  The setuid
2644      * root version must be called suidperl or sperlN.NNN.  If regular perl
2645      * discovers that it has opened a setuid script, it calls suidperl with
2646      * the same argv that it had.  If suidperl finds that the script it has
2647      * just opened is NOT setuid root, it sets the effective uid back to the
2648      * uid.  We don't just make perl setuid root because that loses the
2649      * effective uid we had before invoking perl, if it was different from the
2650      * uid.
2651      *
2652      * DOSUID must be defined in both perl and suidperl, and IAMSUID must
2653      * be defined in suidperl only.  suidperl must be setuid root.  The
2654      * Configure script will set this up for you if you want it.
2655      */
2656
2657 #ifdef DOSUID
2658     dTHR;
2659     char *s, *s2;
2660
2661     if (PerlLIO_fstat(PerlIO_fileno(PL_rsfp),&PL_statbuf) < 0)  /* normal stat is insecure */
2662         Perl_croak(aTHX_ "Can't stat script \"%s\"",PL_origfilename);
2663     if (fdscript < 0 && PL_statbuf.st_mode & (S_ISUID|S_ISGID)) {
2664         I32 len;
2665         STRLEN n_a;
2666
2667 #ifdef IAMSUID
2668 #ifndef HAS_SETREUID
2669         /* On this access check to make sure the directories are readable,
2670          * there is actually a small window that the user could use to make
2671          * filename point to an accessible directory.  So there is a faint
2672          * chance that someone could execute a setuid script down in a
2673          * non-accessible directory.  I don't know what to do about that.
2674          * But I don't think it's too important.  The manual lies when
2675          * it says access() is useful in setuid programs.
2676          */
2677         if (PerlLIO_access(CopFILE(PL_curcop),1)) /*double check*/
2678             Perl_croak(aTHX_ "Permission denied");
2679 #else
2680         /* If we can swap euid and uid, then we can determine access rights
2681          * with a simple stat of the file, and then compare device and
2682          * inode to make sure we did stat() on the same file we opened.
2683          * Then we just have to make sure he or she can execute it.
2684          */
2685         {
2686             struct stat tmpstatbuf;
2687
2688             if (
2689 #ifdef HAS_SETREUID
2690                 setreuid(PL_euid,PL_uid) < 0
2691 #else
2692 # if HAS_SETRESUID
2693                 setresuid(PL_euid,PL_uid,(Uid_t)-1) < 0
2694 # endif
2695 #endif
2696                 || PerlProc_getuid() != PL_euid || PerlProc_geteuid() != PL_uid)
2697                 Perl_croak(aTHX_ "Can't swap uid and euid");    /* really paranoid */
2698             if (PerlLIO_stat(CopFILE(PL_curcop),&tmpstatbuf) < 0)
2699                 Perl_croak(aTHX_ "Permission denied");  /* testing full pathname here */
2700 #if defined(IAMSUID) && !defined(NO_NOSUID_CHECK)
2701             if (fd_on_nosuid_fs(PerlIO_fileno(PL_rsfp)))
2702                 Perl_croak(aTHX_ "Permission denied");
2703 #endif
2704             if (tmpstatbuf.st_dev != PL_statbuf.st_dev ||
2705                 tmpstatbuf.st_ino != PL_statbuf.st_ino) {
2706                 (void)PerlIO_close(PL_rsfp);
2707                 if (PL_rsfp = PerlProc_popen("/bin/mail root","w")) {   /* heh, heh */
2708                     PerlIO_printf(PL_rsfp,
2709 "User %"Uid_t_f" tried to run dev %ld ino %ld in place of dev %ld ino %ld!\n\
2710 (Filename of set-id script was %s, uid %"Uid_t_f" gid %"Gid_t_f".)\n\nSincerely,\nperl\n",
2711                         PL_uid,(long)tmpstatbuf.st_dev, (long)tmpstatbuf.st_ino,
2712                         (long)PL_statbuf.st_dev, (long)PL_statbuf.st_ino,
2713                         CopFILE(PL_curcop),
2714                         PL_statbuf.st_uid, PL_statbuf.st_gid);
2715                     (void)PerlProc_pclose(PL_rsfp);
2716                 }
2717                 Perl_croak(aTHX_ "Permission denied\n");
2718             }
2719             if (
2720 #ifdef HAS_SETREUID
2721               setreuid(PL_uid,PL_euid) < 0
2722 #else
2723 # if defined(HAS_SETRESUID)
2724               setresuid(PL_uid,PL_euid,(Uid_t)-1) < 0
2725 # endif
2726 #endif
2727               || PerlProc_getuid() != PL_uid || PerlProc_geteuid() != PL_euid)
2728                 Perl_croak(aTHX_ "Can't reswap uid and euid");
2729             if (!cando(S_IXUSR,FALSE,&PL_statbuf))              /* can real uid exec? */
2730                 Perl_croak(aTHX_ "Permission denied\n");
2731         }
2732 #endif /* HAS_SETREUID */
2733 #endif /* IAMSUID */
2734
2735         if (!S_ISREG(PL_statbuf.st_mode))
2736             Perl_croak(aTHX_ "Permission denied");
2737         if (PL_statbuf.st_mode & S_IWOTH)
2738             Perl_croak(aTHX_ "Setuid/gid script is writable by world");
2739         PL_doswitches = FALSE;          /* -s is insecure in suid */
2740         CopLINE_inc(PL_curcop);
2741         if (sv_gets(PL_linestr, PL_rsfp, 0) == Nullch ||
2742           strnNE(SvPV(PL_linestr,n_a),"#!",2) ) /* required even on Sys V */
2743             Perl_croak(aTHX_ "No #! line");
2744         s = SvPV(PL_linestr,n_a)+2;
2745         if (*s == ' ') s++;
2746         while (!isSPACE(*s)) s++;
2747         for (s2 = s;  (s2 > SvPV(PL_linestr,n_a)+2 &&
2748                        (isDIGIT(s2[-1]) || strchr("._-", s2[-1])));  s2--) ;
2749         if (strnNE(s2-4,"perl",4) && strnNE(s-9,"perl",4))  /* sanity check */
2750             Perl_croak(aTHX_ "Not a perl script");
2751         while (*s == ' ' || *s == '\t') s++;
2752         /*
2753          * #! arg must be what we saw above.  They can invoke it by
2754          * mentioning suidperl explicitly, but they may not add any strange
2755          * arguments beyond what #! says if they do invoke suidperl that way.
2756          */
2757         len = strlen(validarg);
2758         if (strEQ(validarg," PHOOEY ") ||
2759             strnNE(s,validarg,len) || !isSPACE(s[len]))
2760             Perl_croak(aTHX_ "Args must match #! line");
2761
2762 #ifndef IAMSUID
2763         if (PL_euid != PL_uid && (PL_statbuf.st_mode & S_ISUID) &&
2764             PL_euid == PL_statbuf.st_uid)
2765             if (!PL_do_undump)
2766                 Perl_croak(aTHX_ "YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
2767 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
2768 #endif /* IAMSUID */
2769
2770         if (PL_euid) {  /* oops, we're not the setuid root perl */
2771             (void)PerlIO_close(PL_rsfp);
2772 #ifndef IAMSUID
2773             /* try again */
2774             PerlProc_execv(Perl_form(aTHX_ "%s/sperl"PERL_FS_VER_FMT, BIN_EXP,
2775                                      (int)PERL_REVISION, (int)PERL_VERSION,
2776                                      (int)PERL_SUBVERSION), PL_origargv);
2777 #endif
2778             Perl_croak(aTHX_ "Can't do setuid\n");
2779         }
2780
2781         if (PL_statbuf.st_mode & S_ISGID && PL_statbuf.st_gid != PL_egid) {
2782 #ifdef HAS_SETEGID
2783             (void)setegid(PL_statbuf.st_gid);
2784 #else
2785 #ifdef HAS_SETREGID
2786            (void)setregid((Gid_t)-1,PL_statbuf.st_gid);
2787 #else
2788 #ifdef HAS_SETRESGID
2789            (void)setresgid((Gid_t)-1,PL_statbuf.st_gid,(Gid_t)-1);
2790 #else
2791             PerlProc_setgid(PL_statbuf.st_gid);
2792 #endif
2793 #endif
2794 #endif
2795             if (PerlProc_getegid() != PL_statbuf.st_gid)
2796                 Perl_croak(aTHX_ "Can't do setegid!\n");
2797         }
2798         if (PL_statbuf.st_mode & S_ISUID) {
2799             if (PL_statbuf.st_uid != PL_euid)
2800 #ifdef HAS_SETEUID
2801                 (void)seteuid(PL_statbuf.st_uid);       /* all that for this */
2802 #else
2803 #ifdef HAS_SETREUID
2804                 (void)setreuid((Uid_t)-1,PL_statbuf.st_uid);
2805 #else
2806 #ifdef HAS_SETRESUID
2807                 (void)setresuid((Uid_t)-1,PL_statbuf.st_uid,(Uid_t)-1);
2808 #else
2809                 PerlProc_setuid(PL_statbuf.st_uid);
2810 #endif
2811 #endif
2812 #endif
2813             if (PerlProc_geteuid() != PL_statbuf.st_uid)
2814                 Perl_croak(aTHX_ "Can't do seteuid!\n");
2815         }
2816         else if (PL_uid) {                      /* oops, mustn't run as root */
2817 #ifdef HAS_SETEUID
2818           (void)seteuid((Uid_t)PL_uid);
2819 #else
2820 #ifdef HAS_SETREUID
2821           (void)setreuid((Uid_t)-1,(Uid_t)PL_uid);
2822 #else
2823 #ifdef HAS_SETRESUID
2824           (void)setresuid((Uid_t)-1,(Uid_t)PL_uid,(Uid_t)-1);
2825 #else
2826           PerlProc_setuid((Uid_t)PL_uid);
2827 #endif
2828 #endif
2829 #endif
2830             if (PerlProc_geteuid() != PL_uid)
2831                 Perl_croak(aTHX_ "Can't do seteuid!\n");
2832         }
2833         init_ids();
2834         if (!cando(S_IXUSR,TRUE,&PL_statbuf))
2835             Perl_croak(aTHX_ "Permission denied\n");    /* they can't do this */
2836     }
2837 #ifdef IAMSUID
2838     else if (PL_preprocess)
2839         Perl_croak(aTHX_ "-P not allowed for setuid/setgid script\n");
2840     else if (fdscript >= 0)
2841         Perl_croak(aTHX_ "fd script not allowed in suidperl\n");
2842     else
2843         Perl_croak(aTHX_ "Script is not setuid/setgid in suidperl\n");
2844
2845     /* We absolutely must clear out any saved ids here, so we */
2846     /* exec the real perl, substituting fd script for scriptname. */
2847     /* (We pass script name as "subdir" of fd, which perl will grok.) */
2848     PerlIO_rewind(PL_rsfp);
2849     PerlLIO_lseek(PerlIO_fileno(PL_rsfp),(Off_t)0,0);  /* just in case rewind didn't */
2850     for (which = 1; PL_origargv[which] && PL_origargv[which] != scriptname; which++) ;
2851     if (!PL_origargv[which])
2852         Perl_croak(aTHX_ "Permission denied");
2853     PL_origargv[which] = savepv(Perl_form(aTHX_ "/dev/fd/%d/%s",
2854                                   PerlIO_fileno(PL_rsfp), PL_origargv[which]));
2855 #if defined(HAS_FCNTL) && defined(F_SETFD)
2856     fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,0);    /* ensure no close-on-exec */
2857 #endif
2858     PerlProc_execv(Perl_form(aTHX_ "%s/perl"PERL_FS_VER_FMT, BIN_EXP,
2859                              (int)PERL_REVISION, (int)PERL_VERSION,
2860                              (int)PERL_SUBVERSION), PL_origargv);/* try again */
2861     Perl_croak(aTHX_ "Can't do setuid\n");
2862 #endif /* IAMSUID */
2863 #else /* !DOSUID */
2864     if (PL_euid != PL_uid || PL_egid != PL_gid) {       /* (suidperl doesn't exist, in fact) */
2865 #ifndef SETUID_SCRIPTS_ARE_SECURE_NOW
2866         dTHR;
2867         PerlLIO_fstat(PerlIO_fileno(PL_rsfp),&PL_statbuf);      /* may be either wrapped or real suid */
2868         if ((PL_euid != PL_uid && PL_euid == PL_statbuf.st_uid && PL_statbuf.st_mode & S_ISUID)
2869             ||
2870             (PL_egid != PL_gid && PL_egid == PL_statbuf.st_gid && PL_statbuf.st_mode & S_ISGID)
2871            )
2872             if (!PL_do_undump)
2873                 Perl_croak(aTHX_ "YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
2874 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
2875 #endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
2876         /* not set-id, must be wrapped */
2877     }
2878 #endif /* DOSUID */
2879 }
2880
2881 STATIC void
2882 S_find_beginning(pTHX)
2883 {
2884     register char *s, *s2;
2885
2886     /* skip forward in input to the real script? */
2887
2888     forbid_setid("-x");
2889     while (PL_doextract) {
2890         if ((s = sv_gets(PL_linestr, PL_rsfp, 0)) == Nullch)
2891             Perl_croak(aTHX_ "No Perl script found in input\n");
2892         if (*s == '#' && s[1] == '!' && (s = instr(s,"perl"))) {
2893             PerlIO_ungetc(PL_rsfp, '\n');               /* to keep line count right */
2894             PL_doextract = FALSE;
2895             while (*s && !(isSPACE (*s) || *s == '#')) s++;
2896             s2 = s;
2897             while (*s == ' ' || *s == '\t') s++;
2898             if (*s++ == '-') {
2899                 while (isDIGIT(s2[-1]) || strchr("-._", s2[-1])) s2--;
2900                 if (strnEQ(s2-4,"perl",4))
2901                     /*SUPPRESS 530*/
2902                     while (s = moreswitches(s)) ;
2903             }
2904         }
2905     }
2906 }
2907
2908
2909 STATIC void
2910 S_init_ids(pTHX)
2911 {
2912     PL_uid = PerlProc_getuid();
2913     PL_euid = PerlProc_geteuid();
2914     PL_gid = PerlProc_getgid();
2915     PL_egid = PerlProc_getegid();
2916 #ifdef VMS
2917     PL_uid |= PL_gid << 16;
2918     PL_euid |= PL_egid << 16;
2919 #endif
2920     PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2921 }
2922
2923 STATIC void
2924 S_forbid_setid(pTHX_ char *s)
2925 {
2926     if (PL_euid != PL_uid)
2927         Perl_croak(aTHX_ "No %s allowed while running setuid", s);
2928     if (PL_egid != PL_gid)
2929         Perl_croak(aTHX_ "No %s allowed while running setgid", s);
2930 }
2931
2932 void
2933 Perl_init_debugger(pTHX)
2934 {
2935     dTHR;
2936     HV *ostash = PL_curstash;
2937
2938     PL_curstash = PL_debstash;
2939     PL_dbargs = GvAV(gv_AVadd((gv_fetchpv("args", GV_ADDMULTI, SVt_PVAV))));
2940     AvREAL_off(PL_dbargs);
2941     PL_DBgv = gv_fetchpv("DB", GV_ADDMULTI, SVt_PVGV);
2942     PL_DBline = gv_fetchpv("dbline", GV_ADDMULTI, SVt_PVAV);
2943     PL_DBsub = gv_HVadd(gv_fetchpv("sub", GV_ADDMULTI, SVt_PVHV));
2944     sv_upgrade(GvSV(PL_DBsub), SVt_IV); /* IVX accessed if PERLDB_SUB_NN */
2945     PL_DBsingle = GvSV((gv_fetchpv("single", GV_ADDMULTI, SVt_PV)));
2946     sv_setiv(PL_DBsingle, 0);
2947     PL_DBtrace = GvSV((gv_fetchpv("trace", GV_ADDMULTI, SVt_PV)));
2948     sv_setiv(PL_DBtrace, 0);
2949     PL_DBsignal = GvSV((gv_fetchpv("signal", GV_ADDMULTI, SVt_PV)));
2950     sv_setiv(PL_DBsignal, 0);
2951     PL_curstash = ostash;
2952 }
2953
2954 #ifndef STRESS_REALLOC
2955 #define REASONABLE(size) (size)
2956 #else
2957 #define REASONABLE(size) (1) /* unreasonable */
2958 #endif
2959
2960 void
2961 Perl_init_stacks(pTHX)
2962 {
2963     /* start with 128-item stack and 8K cxstack */
2964     PL_curstackinfo = new_stackinfo(REASONABLE(128),
2965                                  REASONABLE(8192/sizeof(PERL_CONTEXT) - 1));
2966     PL_curstackinfo->si_type = PERLSI_MAIN;
2967     PL_curstack = PL_curstackinfo->si_stack;
2968     PL_mainstack = PL_curstack;         /* remember in case we switch stacks */
2969
2970     PL_stack_base = AvARRAY(PL_curstack);
2971     PL_stack_sp = PL_stack_base;
2972     PL_stack_max = PL_stack_base + AvMAX(PL_curstack);
2973
2974     New(50,PL_tmps_stack,REASONABLE(128),SV*);
2975     PL_tmps_floor = -1;
2976     PL_tmps_ix = -1;
2977     PL_tmps_max = REASONABLE(128);
2978
2979     New(54,PL_markstack,REASONABLE(32),I32);
2980     PL_markstack_ptr = PL_markstack;
2981     PL_markstack_max = PL_markstack + REASONABLE(32);
2982
2983     SET_MARK_OFFSET;
2984
2985     New(54,PL_scopestack,REASONABLE(32),I32);
2986     PL_scopestack_ix = 0;
2987     PL_scopestack_max = REASONABLE(32);
2988
2989     New(54,PL_savestack,REASONABLE(128),ANY);
2990     PL_savestack_ix = 0;
2991     PL_savestack_max = REASONABLE(128);
2992
2993     New(54,PL_retstack,REASONABLE(16),OP*);
2994     PL_retstack_ix = 0;
2995     PL_retstack_max = REASONABLE(16);
2996 }
2997
2998 #undef REASONABLE
2999
3000 STATIC void
3001 S_nuke_stacks(pTHX)
3002 {
3003     dTHR;
3004     while (PL_curstackinfo->si_next)
3005         PL_curstackinfo = PL_curstackinfo->si_next;
3006     while (PL_curstackinfo) {
3007         PERL_SI *p = PL_curstackinfo->si_prev;
3008         /* curstackinfo->si_stack got nuked by sv_free_arenas() */
3009         Safefree(PL_curstackinfo->si_cxstack);
3010         Safefree(PL_curstackinfo);
3011         PL_curstackinfo = p;
3012     }
3013     Safefree(PL_tmps_stack);
3014     Safefree(PL_markstack);
3015     Safefree(PL_scopestack);
3016     Safefree(PL_savestack);
3017     Safefree(PL_retstack);
3018 }
3019
3020 #ifndef PERL_OBJECT
3021 static PerlIO *tmpfp;  /* moved outside init_lexer() because of UNICOS bug */
3022 #endif
3023
3024 STATIC void
3025 S_init_lexer(pTHX)
3026 {
3027 #ifdef PERL_OBJECT
3028         PerlIO *tmpfp;
3029 #endif
3030     tmpfp = PL_rsfp;
3031     PL_rsfp = Nullfp;
3032     lex_start(PL_linestr);
3033     PL_rsfp = tmpfp;
3034     PL_subname = newSVpvn("main",4);
3035 }
3036
3037 STATIC void
3038 S_init_predump_symbols(pTHX)
3039 {
3040     dTHR;
3041     GV *tmpgv;
3042     GV *othergv;
3043     IO *io;
3044
3045     sv_setpvn(get_sv("\"", TRUE), " ", 1);
3046     PL_stdingv = gv_fetchpv("STDIN",TRUE, SVt_PVIO);
3047     GvMULTI_on(PL_stdingv);
3048     io = GvIOp(PL_stdingv);
3049     IoIFP(io) = PerlIO_stdin();
3050     tmpgv = gv_fetchpv("stdin",TRUE, SVt_PV);
3051     GvMULTI_on(tmpgv);
3052     GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io);
3053
3054     tmpgv = gv_fetchpv("STDOUT",TRUE, SVt_PVIO);
3055     GvMULTI_on(tmpgv);
3056     io = GvIOp(tmpgv);
3057     IoOFP(io) = IoIFP(io) = PerlIO_stdout();
3058     setdefout(tmpgv);
3059     tmpgv = gv_fetchpv("stdout",TRUE, SVt_PV);
3060     GvMULTI_on(tmpgv);
3061     GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io);
3062
3063     PL_stderrgv = gv_fetchpv("STDERR",TRUE, SVt_PVIO);
3064     GvMULTI_on(PL_stderrgv);
3065     io = GvIOp(PL_stderrgv);
3066     IoOFP(io) = IoIFP(io) = PerlIO_stderr();
3067     tmpgv = gv_fetchpv("stderr",TRUE, SVt_PV);
3068     GvMULTI_on(tmpgv);
3069     GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io);
3070
3071     PL_statname = NEWSV(66,0);          /* last filename we did stat on */
3072
3073     if (!PL_osname)
3074         PL_osname = savepv(OSNAME);
3075 }
3076
3077 STATIC void
3078 S_init_postdump_symbols(pTHX_ register int argc, register char **argv, register char **env)
3079 {
3080     dTHR;
3081     char *s;
3082     SV *sv;
3083     GV* tmpgv;
3084
3085     argc--,argv++;      /* skip name of script */
3086     if (PL_doswitches) {
3087         for (; argc > 0 && **argv == '-'; argc--,argv++) {
3088             if (!argv[0][1])
3089                 break;
3090             if (argv[0][1] == '-' && !argv[0][2]) {
3091                 argc--,argv++;
3092                 break;
3093             }
3094             if (s = strchr(argv[0], '=')) {
3095                 *s++ = '\0';
3096                 sv_setpv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),s);
3097             }
3098             else
3099                 sv_setiv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),1);
3100         }
3101     }
3102     PL_toptarget = NEWSV(0,0);
3103     sv_upgrade(PL_toptarget, SVt_PVFM);
3104     sv_setpvn(PL_toptarget, "", 0);
3105     PL_bodytarget = NEWSV(0,0);
3106     sv_upgrade(PL_bodytarget, SVt_PVFM);
3107     sv_setpvn(PL_bodytarget, "", 0);
3108     PL_formtarget = PL_bodytarget;
3109
3110     TAINT;
3111     if (tmpgv = gv_fetchpv("0",TRUE, SVt_PV)) {
3112         sv_setpv(GvSV(tmpgv),PL_origfilename);
3113         magicname("0", "0", 1);
3114     }
3115     if (tmpgv = gv_fetchpv("\030",TRUE, SVt_PV))
3116 #ifdef OS2
3117         sv_setpv(GvSV(tmpgv), os2_execname());
3118 #else
3119         sv_setpv(GvSV(tmpgv),PL_origargv[0]);
3120 #endif
3121     if (PL_argvgv = gv_fetchpv("ARGV",TRUE, SVt_PVAV)) {
3122         GvMULTI_on(PL_argvgv);
3123         (void)gv_AVadd(PL_argvgv);
3124         av_clear(GvAVn(PL_argvgv));
3125         for (; argc > 0; argc--,argv++) {
3126             av_push(GvAVn(PL_argvgv),newSVpv(argv[0],0));
3127         }
3128     }
3129     if (PL_envgv = gv_fetchpv("ENV",TRUE, SVt_PVHV)) {
3130         HV *hv;
3131         GvMULTI_on(PL_envgv);
3132         hv = GvHVn(PL_envgv);
3133         hv_magic(hv, PL_envgv, 'E');
3134 #if !defined( VMS) && !defined(EPOC)  /* VMS doesn't have environ array */
3135         /* Note that if the supplied env parameter is actually a copy
3136            of the global environ then it may now point to free'd memory
3137            if the environment has been modified since. To avoid this
3138            problem we treat env==NULL as meaning 'use the default'
3139         */
3140         if (!env)
3141             env = environ;
3142         if (env != environ)
3143             environ[0] = Nullch;
3144         for (; *env; env++) {
3145             if (!(s = strchr(*env,'=')))
3146                 continue;
3147             *s++ = '\0';
3148 #if defined(MSDOS)
3149             (void)strupr(*env);
3150 #endif
3151             sv = newSVpv(s--,0);
3152             (void)hv_store(hv, *env, s - *env, sv, 0);
3153             *s = '=';
3154 #if defined(__BORLANDC__) && defined(USE_WIN32_RTL_ENV)
3155             /* Sins of the RTL. See note in my_setenv(). */
3156             (void)PerlEnv_putenv(savepv(*env));
3157 #endif
3158         }
3159 #endif
3160 #ifdef DYNAMIC_ENV_FETCH
3161         HvNAME(hv) = savepv(ENV_HV_NAME);
3162 #endif
3163     }
3164     TAINT_NOT;
3165     if (tmpgv = gv_fetchpv("$",TRUE, SVt_PV))
3166         sv_setiv(GvSV(tmpgv), (IV)PerlProc_getpid());
3167 }
3168
3169 STATIC void
3170 S_init_perllib(pTHX)
3171 {
3172     char *s;
3173     if (!PL_tainting) {
3174 #ifndef VMS
3175         s = PerlEnv_getenv("PERL5LIB");
3176         if (s)
3177             incpush(s, TRUE);
3178         else
3179             incpush(PerlEnv_getenv("PERLLIB"), FALSE);
3180 #else /* VMS */
3181         /* Treat PERL5?LIB as a possible search list logical name -- the
3182          * "natural" VMS idiom for a Unix path string.  We allow each
3183          * element to be a set of |-separated directories for compatibility.
3184          */
3185         char buf[256];
3186         int idx = 0;
3187         if (my_trnlnm("PERL5LIB",buf,0))
3188             do { incpush(buf,TRUE); } while (my_trnlnm("PERL5LIB",buf,++idx));
3189         else
3190             while (my_trnlnm("PERLLIB",buf,idx++)) incpush(buf,FALSE);
3191 #endif /* VMS */
3192     }
3193
3194 /* Use the ~-expanded versions of APPLLIB (undocumented),
3195     ARCHLIB PRIVLIB SITEARCH and SITELIB
3196 */
3197 #ifdef APPLLIB_EXP
3198     incpush(APPLLIB_EXP, TRUE);
3199 #endif
3200
3201 #ifdef ARCHLIB_EXP
3202     incpush(ARCHLIB_EXP, FALSE);
3203 #endif
3204 #ifndef PRIVLIB_EXP
3205 #define PRIVLIB_EXP "/usr/local/lib/perl5:/usr/local/lib/perl"
3206 #endif
3207 #if defined(WIN32)
3208     incpush(PRIVLIB_EXP, TRUE);
3209 #else
3210     incpush(PRIVLIB_EXP, FALSE);
3211 #endif
3212
3213 #if defined(WIN32)
3214     incpush(SITELIB_EXP, TRUE); /* XXX Win32 needs inc_version_list support */
3215 #else
3216 #ifdef SITELIB_EXP
3217     {
3218         char *path = SITELIB_EXP;
3219
3220         if (path) {
3221             char buf[1024];
3222             strcpy(buf,path);
3223             if (strrchr(buf,'/'))       /* XXX Hack, Configure var needed */
3224                 *strrchr(buf,'/') = '\0';
3225             incpush(buf, TRUE);
3226         }
3227     }
3228 #endif
3229 #endif
3230 #if defined(PERL_VENDORLIB_EXP)
3231 #if defined(WIN32)
3232     incpush(PERL_VENDORLIB_EXP, TRUE);
3233 #else
3234     incpush(PERL_VENDORLIB_EXP, FALSE);
3235 #endif
3236 #endif
3237     if (!PL_tainting)
3238         incpush(".", FALSE);
3239 }
3240
3241 #if defined(DOSISH)
3242 #    define PERLLIB_SEP ';'
3243 #else
3244 #  if defined(VMS)
3245 #    define PERLLIB_SEP '|'
3246 #  else
3247 #    define PERLLIB_SEP ':'
3248 #  endif
3249 #endif
3250 #ifndef PERLLIB_MANGLE
3251 #  define PERLLIB_MANGLE(s,n) (s)
3252 #endif
3253
3254 STATIC void
3255 S_incpush(pTHX_ char *p, int addsubdirs)
3256 {
3257     SV *subdir = Nullsv;
3258
3259     if (!p)
3260         return;
3261
3262     if (addsubdirs) {
3263         subdir = sv_newmortal();
3264     }
3265
3266     /* Break at all separators */
3267     while (p && *p) {
3268         SV *libdir = NEWSV(55,0);
3269         char *s;
3270
3271         /* skip any consecutive separators */
3272         while ( *p == PERLLIB_SEP ) {
3273             /* Uncomment the next line for PATH semantics */
3274             /* av_push(GvAVn(PL_incgv), newSVpvn(".", 1)); */
3275             p++;
3276         }
3277
3278         if ( (s = strchr(p, PERLLIB_SEP)) != Nullch ) {
3279             sv_setpvn(libdir, PERLLIB_MANGLE(p, (STRLEN)(s - p)),
3280                       (STRLEN)(s - p));
3281             p = s + 1;
3282         }
3283         else {
3284             sv_setpv(libdir, PERLLIB_MANGLE(p, 0));
3285             p = Nullch; /* break out */
3286         }
3287
3288         /*
3289          * BEFORE pushing libdir onto @INC we may first push version- and
3290          * archname-specific sub-directories.
3291          */
3292         if (addsubdirs) {
3293 #ifdef PERL_INC_VERSION_LIST
3294             /* Configure terminates PERL_INC_VERSION_LIST with a NULL */
3295             const char *incverlist[] = { PERL_INC_VERSION_LIST };
3296             const char **incver;
3297 #endif
3298             struct stat tmpstatbuf;
3299 #ifdef VMS
3300             char *unix;
3301             STRLEN len;
3302
3303             if ((unix = tounixspec_ts(SvPV(libdir,len),Nullch)) != Nullch) {
3304                 len = strlen(unix);
3305                 while (unix[len-1] == '/') len--;  /* Cosmetic */
3306                 sv_usepvn(libdir,unix,len);
3307             }
3308             else
3309                 PerlIO_printf(Perl_error_log,
3310                               "Failed to unixify @INC element \"%s\"\n",
3311                               SvPV(libdir,len));
3312 #endif
3313             /* .../version/archname if -d .../version/archname */
3314             Perl_sv_setpvf(aTHX_ subdir, "%"SVf"/"PERL_FS_VER_FMT"/%s", libdir,
3315                            (int)PERL_REVISION, (int)PERL_VERSION,
3316                            (int)PERL_SUBVERSION, ARCHNAME);
3317             if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
3318                   S_ISDIR(tmpstatbuf.st_mode))
3319                 av_push(GvAVn(PL_incgv), newSVsv(subdir));
3320
3321             /* .../version if -d .../version */
3322             Perl_sv_setpvf(aTHX_ subdir, "%"SVf"/"PERL_FS_VER_FMT, libdir,
3323                            (int)PERL_REVISION, (int)PERL_VERSION,
3324                            (int)PERL_SUBVERSION);
3325             if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
3326                   S_ISDIR(tmpstatbuf.st_mode))
3327                 av_push(GvAVn(PL_incgv), newSVsv(subdir));
3328
3329             /* .../archname if -d .../archname */
3330             Perl_sv_setpvf(aTHX_ subdir, "%"SVf"/%s", libdir, ARCHNAME);
3331             if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
3332                   S_ISDIR(tmpstatbuf.st_mode))
3333                 av_push(GvAVn(PL_incgv), newSVsv(subdir));
3334
3335 #ifdef PERL_INC_VERSION_LIST
3336             for (incver = incverlist; *incver; incver++) {
3337                 /* .../xxx if -d .../xxx */
3338                 Perl_sv_setpvf(aTHX_ subdir, "%"SVf"/%s", libdir, *incver);
3339                 if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
3340                       S_ISDIR(tmpstatbuf.st_mode))
3341                     av_push(GvAVn(PL_incgv), newSVsv(subdir));
3342             }
3343 #endif
3344         }
3345
3346         /* finally push this lib directory on the end of @INC */
3347         av_push(GvAVn(PL_incgv), libdir);
3348     }
3349 }
3350
3351 #ifdef USE_THREADS
3352 STATIC struct perl_thread *
3353 S_init_main_thread(pTHX)
3354 {
3355 #if !defined(PERL_IMPLICIT_CONTEXT)
3356     struct perl_thread *thr;
3357 #endif
3358     XPV *xpv;
3359
3360     Newz(53, thr, 1, struct perl_thread);
3361     PL_curcop = &PL_compiling;
3362     thr->interp = PERL_GET_INTERP;
3363     thr->cvcache = newHV();
3364     thr->threadsv = newAV();
3365     /* thr->threadsvp is set when find_threadsv is called */
3366     thr->specific = newAV();
3367     thr->flags = THRf_R_JOINABLE;
3368     MUTEX_INIT(&thr->mutex);
3369     /* Handcraft thrsv similarly to mess_sv */
3370     New(53, PL_thrsv, 1, SV);
3371     Newz(53, xpv, 1, XPV);
3372     SvFLAGS(PL_thrsv) = SVt_PV;
3373     SvANY(PL_thrsv) = (void*)xpv;
3374     SvREFCNT(PL_thrsv) = 1 << 30;       /* practically infinite */
3375     SvPVX(PL_thrsv) = (char*)thr;
3376     SvCUR_set(PL_thrsv, sizeof(thr));
3377     SvLEN_set(PL_thrsv, sizeof(thr));
3378     *SvEND(PL_thrsv) = '\0';    /* in the trailing_nul field */
3379     thr->oursv = PL_thrsv;
3380     PL_chopset = " \n-";
3381     PL_dumpindent = 4;
3382
3383     MUTEX_LOCK(&PL_threads_mutex);
3384     PL_nthreads++;
3385     thr->tid = 0;
3386     thr->next = thr;
3387     thr->prev = thr;
3388     MUTEX_UNLOCK(&PL_threads_mutex);
3389
3390 #ifdef HAVE_THREAD_INTERN
3391     Perl_init_thread_intern(thr);
3392 #endif
3393
3394 #ifdef SET_THREAD_SELF
3395     SET_THREAD_SELF(thr);
3396 #else
3397     thr->self = pthread_self();
3398 #endif /* SET_THREAD_SELF */
3399     SET_THR(thr);
3400
3401     /*
3402      * These must come after the SET_THR because sv_setpvn does
3403      * SvTAINT and the taint fields require dTHR.
3404      */
3405     PL_toptarget = NEWSV(0,0);
3406     sv_upgrade(PL_toptarget, SVt_PVFM);
3407     sv_setpvn(PL_toptarget, "", 0);
3408     PL_bodytarget = NEWSV(0,0);
3409     sv_upgrade(PL_bodytarget, SVt_PVFM);
3410     sv_setpvn(PL_bodytarget, "", 0);
3411     PL_formtarget = PL_bodytarget;
3412     thr->errsv = newSVpvn("", 0);
3413     (void) find_threadsv("@");  /* Ensure $@ is initialised early */
3414
3415     PL_maxscream = -1;
3416     PL_regcompp = MEMBER_TO_FPTR(Perl_pregcomp);
3417     PL_regexecp = MEMBER_TO_FPTR(Perl_regexec_flags);
3418     PL_regint_start = MEMBER_TO_FPTR(Perl_re_intuit_start);
3419     PL_regint_string = MEMBER_TO_FPTR(Perl_re_intuit_string);
3420     PL_regfree = MEMBER_TO_FPTR(Perl_pregfree);
3421     PL_regindent = 0;
3422     PL_reginterp_cnt = 0;
3423
3424     return thr;
3425 }
3426 #endif /* USE_THREADS */
3427
3428 void
3429 Perl_call_list(pTHX_ I32 oldscope, AV *paramList)
3430 {
3431     dTHR;
3432     SV *atsv;
3433     line_t oldline = CopLINE(PL_curcop);
3434     CV *cv;
3435     STRLEN len;
3436     int ret;
3437     dJMPENV;
3438
3439     while (AvFILL(paramList) >= 0) {
3440         cv = (CV*)av_shift(paramList);
3441         SAVEFREESV(cv);
3442 #ifdef PERL_FLEXIBLE_EXCEPTIONS
3443         CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_vcall_list_body), cv);
3444 #else
3445         JMPENV_PUSH(ret);
3446 #endif
3447         switch (ret) {
3448         case 0:
3449 #ifndef PERL_FLEXIBLE_EXCEPTIONS
3450             call_list_body(cv);
3451 #endif
3452             atsv = ERRSV;
3453             (void)SvPV(atsv, len);
3454             if (len) {
3455                 STRLEN n_a;
3456                 PL_curcop = &PL_compiling;
3457                 CopLINE_set(PL_curcop, oldline);
3458                 if (paramList == PL_beginav)
3459                     sv_catpv(atsv, "BEGIN failed--compilation aborted");
3460                 else
3461                     Perl_sv_catpvf(aTHX_ atsv,
3462                                    "%s failed--call queue aborted",
3463                                    paramList == PL_checkav ? "CHECK"
3464                                    : paramList == PL_initav ? "INIT"
3465                                    : "END");
3466                 while (PL_scopestack_ix > oldscope)
3467                     LEAVE;
3468                 JMPENV_POP;
3469                 Perl_croak(aTHX_ "%s", SvPVx(atsv, n_a));
3470             }
3471             break;
3472         case 1:
3473             STATUS_ALL_FAILURE;
3474             /* FALL THROUGH */
3475         case 2:
3476             /* my_exit() was called */
3477             while (PL_scopestack_ix > oldscope)
3478                 LEAVE;
3479             FREETMPS;
3480             PL_curstash = PL_defstash;
3481             PL_curcop = &PL_compiling;
3482             CopLINE_set(PL_curcop, oldline);
3483             JMPENV_POP;
3484             if (PL_statusvalue && !(PL_exit_flags & PERL_EXIT_EXPECTED)) {
3485                 if (paramList == PL_beginav)
3486                     Perl_croak(aTHX_ "BEGIN failed--compilation aborted");
3487                 else
3488                     Perl_croak(aTHX_ "%s failed--call queue aborted",
3489                                paramList == PL_checkav ? "CHECK"
3490                                : paramList == PL_initav ? "INIT"
3491                                : "END");
3492             }
3493             my_exit_jump();
3494             /* NOTREACHED */
3495         case 3:
3496             if (PL_restartop) {
3497                 PL_curcop = &PL_compiling;
3498                 CopLINE_set(PL_curcop, oldline);
3499                 JMPENV_JUMP(3);
3500             }
3501             PerlIO_printf(Perl_error_log, "panic: restartop\n");
3502             FREETMPS;
3503             break;
3504         }
3505         JMPENV_POP;
3506     }
3507 }
3508
3509 #ifdef PERL_FLEXIBLE_EXCEPTIONS
3510 STATIC void *
3511 S_vcall_list_body(pTHX_ va_list args)
3512 {
3513     CV *cv = va_arg(args, CV*);
3514     return call_list_body(cv);
3515 }
3516 #endif
3517
3518 STATIC void *
3519 S_call_list_body(pTHX_ CV *cv)
3520 {
3521     PUSHMARK(PL_stack_sp);
3522     call_sv((SV*)cv, G_EVAL|G_DISCARD);
3523     return NULL;
3524 }
3525
3526 void
3527 Perl_my_exit(pTHX_ U32 status)
3528 {
3529     dTHR;
3530
3531     DEBUG_S(PerlIO_printf(Perl_debug_log, "my_exit: thread %p, status %lu\n",
3532                           thr, (unsigned long) status));
3533     switch (status) {
3534     case 0:
3535         STATUS_ALL_SUCCESS;
3536         break;
3537     case 1:
3538         STATUS_ALL_FAILURE;
3539         break;
3540     default:
3541         STATUS_NATIVE_SET(status);
3542         break;
3543     }
3544     my_exit_jump();
3545 }
3546
3547 void
3548 Perl_my_failure_exit(pTHX)
3549 {
3550 #ifdef VMS
3551     if (vaxc$errno & 1) {
3552         if (STATUS_NATIVE & 1)          /* fortuitiously includes "-1" */
3553             STATUS_NATIVE_SET(44);
3554     }
3555     else {
3556         if (!vaxc$errno && errno)       /* unlikely */
3557             STATUS_NATIVE_SET(44);
3558         else
3559             STATUS_NATIVE_SET(vaxc$errno);
3560     }
3561 #else
3562     int exitstatus;
3563     if (errno & 255)
3564         STATUS_POSIX_SET(errno);
3565     else {
3566         exitstatus = STATUS_POSIX >> 8;
3567         if (exitstatus & 255)
3568             STATUS_POSIX_SET(exitstatus);
3569         else
3570             STATUS_POSIX_SET(255);
3571     }
3572 #endif
3573     my_exit_jump();
3574 }
3575
3576 STATIC void
3577 S_my_exit_jump(pTHX)
3578 {
3579     dTHR;
3580     register PERL_CONTEXT *cx;
3581     I32 gimme;
3582     SV **newsp;
3583
3584     if (PL_e_script) {
3585         SvREFCNT_dec(PL_e_script);
3586         PL_e_script = Nullsv;
3587     }
3588
3589     POPSTACK_TO(PL_mainstack);
3590     if (cxstack_ix >= 0) {
3591         if (cxstack_ix > 0)
3592             dounwind(0);
3593         POPBLOCK(cx,PL_curpm);
3594         LEAVE;
3595     }
3596
3597     JMPENV_JUMP(2);
3598 }
3599
3600 #ifdef PERL_OBJECT
3601 #include "XSUB.h"
3602 #endif
3603
3604 static I32
3605 read_e_script(pTHXo_ int idx, SV *buf_sv, int maxlen)
3606 {
3607     char *p, *nl;
3608     p  = SvPVX(PL_e_script);
3609     nl = strchr(p, '\n');
3610     nl = (nl) ? nl+1 : SvEND(PL_e_script);
3611     if (nl-p == 0) {
3612         filter_del(read_e_script);
3613         return 0;
3614     }
3615     sv_catpvn(buf_sv, p, nl-p);
3616     sv_chop(PL_e_script, nl);
3617     return 1;
3618 }