perl.c

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