perl.c

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