perl.c

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