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