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