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