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