perl.c

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