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 MSDOS
2245         PerlIO_printf(PerlIO_stdout(),
2246                       "\nMS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n");
2247 #endif
2248 #ifdef DJGPP
2249         PerlIO_printf(PerlIO_stdout(),
2250                       "djgpp v2 port (jpl5003c) by Hirofumi Watanabe, 1996\n"
2251                       "djgpp v2 port (perl5004+) by Laszlo Molnar, 1997-1999\n");
2252 #endif
2253 #ifdef OS2
2254         PerlIO_printf(PerlIO_stdout(),
2255                       "\n\nOS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n"
2256                       "Version 5 port Copyright (c) 1994-1999, Andreas Kaiser, Ilya Zakharevich\n");
2257 #endif
2258 #ifdef atarist
2259         PerlIO_printf(PerlIO_stdout(),
2260                       "atariST series port, ++jrb  bammi@cadence.com\n");
2261 #endif
2262 #ifdef __BEOS__
2263         PerlIO_printf(PerlIO_stdout(),
2264                       "BeOS port Copyright Tom Spindler, 1997-1999\n");
2265 #endif
2266 #ifdef MPE
2267         PerlIO_printf(PerlIO_stdout(),
2268                       "MPE/iX port Copyright by Mark Klein and Mark Bixby, 1996-1999\n");
2269 #endif
2270 #ifdef OEMVS
2271         PerlIO_printf(PerlIO_stdout(),
2272                       "MVS (OS390) port by Mortice Kern Systems, 1997-1999\n");
2273 #endif
2274 #ifdef __VOS__
2275         PerlIO_printf(PerlIO_stdout(),
2276                       "Stratus VOS port by Paul_Green@stratus.com, 1997-1999\n");
2277 #endif
2278 #ifdef __OPEN_VM
2279         PerlIO_printf(PerlIO_stdout(),
2280                       "VM/ESA port by Neale Ferguson, 1998-1999\n");
2281 #endif
2282 #ifdef POSIX_BC
2283         PerlIO_printf(PerlIO_stdout(),
2284                       "BS2000 (POSIX) port by Start Amadeus GmbH, 1998-1999\n");
2285 #endif
2286 #ifdef __MINT__
2287         PerlIO_printf(PerlIO_stdout(),
2288                       "MiNT port by Guido Flohr, 1997-1999\n");
2289 #endif
2290 #ifdef EPOC
2291         PerlIO_printf(PerlIO_stdout(),
2292                       "EPOC port by Olaf Flebbe, 1999-2000\n");
2293 #endif
2294 #ifdef BINARY_BUILD_NOTICE
2295         BINARY_BUILD_NOTICE;
2296 #endif
2297         PerlIO_printf(PerlIO_stdout(),
2298                       "\n\
2299 Perl may be copied only under the terms of either the Artistic License or the\n\
2300 GNU General Public License, which may be found in the Perl 5.0 source kit.\n\n\
2301 Complete documentation for Perl, including FAQ lists, should be found on\n\
2302 this system using `man perl' or `perldoc perl'.  If you have access to the\n\
2303 Internet, point your browser at http://www.perl.com/, the Perl Home Page.\n\n");
2304         PerlProc_exit(0);
2305     case 'w':
2306         if (! (PL_dowarn & G_WARN_ALL_MASK))
2307             PL_dowarn |= G_WARN_ON;
2308         s++;
2309         return s;
2310     case 'W':
2311         PL_dowarn = G_WARN_ALL_ON|G_WARN_ON;
2312         PL_compiling.cop_warnings = pWARN_ALL ;
2313         s++;
2314         return s;
2315     case 'X':
2316         PL_dowarn = G_WARN_ALL_OFF;
2317         PL_compiling.cop_warnings = pWARN_NONE ;
2318         s++;
2319         return s;
2320     case '*':
2321     case ' ':
2322         if (s[1] == '-')        /* Additional switches on #! line. */
2323             return s+2;
2324         break;
2325     case '-':
2326     case 0:
2327 #if defined(WIN32) || !defined(PERL_STRICT_CR)
2328     case '\r':
2329 #endif
2330     case '\n':
2331     case '\t':
2332         break;
2333 #ifdef ALTERNATE_SHEBANG
2334     case 'S':                   /* OS/2 needs -S on "extproc" line. */
2335         break;
2336 #endif
2337     case 'P':
2338         if (PL_preprocess)
2339             return s+1;
2340         /* FALL THROUGH */
2341     default:
2342         Perl_croak(aTHX_ "Can't emulate -%.1s on #! line",s);
2343     }
2344     return Nullch;
2345 }
2346
2347 /* compliments of Tom Christiansen */
2348
2349 /* unexec() can be found in the Gnu emacs distribution */
2350 /* Known to work with -DUNEXEC and using unexelf.c from GNU emacs-20.2 */
2351
2352 void
2353 Perl_my_unexec(pTHX)
2354 {
2355 #ifdef UNEXEC
2356     SV*    prog;
2357     SV*    file;
2358     int    status = 1;
2359     extern int etext;
2360
2361     prog = newSVpv(BIN_EXP, 0);
2362     sv_catpv(prog, "/perl");
2363     file = newSVpv(PL_origfilename, 0);
2364     sv_catpv(file, ".perldump");
2365
2366     unexec(SvPVX(file), SvPVX(prog), &etext, sbrk(0), 0);
2367     /* unexec prints msg to stderr in case of failure */
2368     PerlProc_exit(status);
2369 #else
2370 #  ifdef VMS
2371 #    include <lib$routines.h>
2372      lib$signal(SS$_DEBUG);  /* ssdef.h #included from vmsish.h */
2373 #  else
2374     ABORT();            /* for use with undump */
2375 #  endif
2376 #endif
2377 }
2378
2379 /* initialize curinterp */
2380 STATIC void
2381 S_init_interp(pTHX)
2382 {
2383
2384 #ifdef PERL_OBJECT              /* XXX kludge */
2385 #define I_REINIT \
2386   STMT_START {                          \
2387     PL_chopset          = " \n-";       \
2388     PL_copline          = NOLINE;       \
2389     PL_curcop           = &PL_compiling;\
2390     PL_curcopdb         = NULL;         \
2391     PL_dbargs           = 0;            \
2392     PL_dumpindent       = 4;            \
2393     PL_laststatval      = -1;           \
2394     PL_laststype        = OP_STAT;      \
2395     PL_maxscream        = -1;           \
2396     PL_maxsysfd         = MAXSYSFD;     \
2397     PL_statname         = Nullsv;       \
2398     PL_tmps_floor       = -1;           \
2399     PL_tmps_ix          = -1;           \
2400     PL_op_mask          = NULL;         \
2401     PL_laststatval      = -1;           \
2402     PL_laststype        = OP_STAT;      \
2403     PL_mess_sv          = Nullsv;       \
2404     PL_splitstr         = " ";          \
2405     PL_generation       = 100;          \
2406     PL_exitlist         = NULL;         \
2407     PL_exitlistlen      = 0;            \
2408     PL_regindent        = 0;            \
2409     PL_in_clean_objs    = FALSE;        \
2410     PL_in_clean_all     = FALSE;        \
2411     PL_profiledata      = NULL;         \
2412     PL_rsfp             = Nullfp;       \
2413     PL_rsfp_filters     = Nullav;       \
2414     PL_dirty            = FALSE;        \
2415   } STMT_END
2416     I_REINIT;
2417 #else
2418 #  ifdef MULTIPLICITY
2419 #    define PERLVAR(var,type)
2420 #    define PERLVARA(var,n,type)
2421 #    if defined(PERL_IMPLICIT_CONTEXT)
2422 #      if defined(USE_THREADS)
2423 #        define PERLVARI(var,type,init)         PERL_GET_INTERP->var = init;
2424 #        define PERLVARIC(var,type,init)        PERL_GET_INTERP->var = init;
2425 #      else /* !USE_THREADS */
2426 #        define PERLVARI(var,type,init)         aTHX->var = init;
2427 #        define PERLVARIC(var,type,init)        aTHX->var = init;
2428 #      endif /* USE_THREADS */
2429 #    else
2430 #      define PERLVARI(var,type,init)   PERL_GET_INTERP->var = init;
2431 #      define PERLVARIC(var,type,init)  PERL_GET_INTERP->var = init;
2432 #    endif
2433 #    include "intrpvar.h"
2434 #    ifndef USE_THREADS
2435 #      include "thrdvar.h"
2436 #    endif
2437 #    undef PERLVAR
2438 #    undef PERLVARA
2439 #    undef PERLVARI
2440 #    undef PERLVARIC
2441 #  else
2442 #    define PERLVAR(var,type)
2443 #    define PERLVARA(var,n,type)
2444 #    define PERLVARI(var,type,init)     PL_##var = init;
2445 #    define PERLVARIC(var,type,init)    PL_##var = init;
2446 #    include "intrpvar.h"
2447 #    ifndef USE_THREADS
2448 #      include "thrdvar.h"
2449 #    endif
2450 #    undef PERLVAR
2451 #    undef PERLVARA
2452 #    undef PERLVARI
2453 #    undef PERLVARIC
2454 #  endif
2455 #endif
2456
2457 }
2458
2459 STATIC void
2460 S_init_main_stash(pTHX)
2461 {
2462     dTHR;
2463     GV *gv;
2464
2465     /* Note that strtab is a rather special HV.  Assumptions are made
2466        about not iterating on it, and not adding tie magic to it.
2467        It is properly deallocated in perl_destruct() */
2468     PL_strtab = newHV();
2469 #ifdef USE_THREADS
2470     MUTEX_INIT(&PL_strtab_mutex);
2471 #endif
2472     HvSHAREKEYS_off(PL_strtab);                 /* mandatory */
2473     hv_ksplit(PL_strtab, 512);
2474
2475     PL_curstash = PL_defstash = newHV();
2476     PL_curstname = newSVpvn("main",4);
2477     gv = gv_fetchpv("main::",TRUE, SVt_PVHV);
2478     SvREFCNT_dec(GvHV(gv));
2479     GvHV(gv) = (HV*)SvREFCNT_inc(PL_defstash);
2480     SvREADONLY_on(gv);
2481     HvNAME(PL_defstash) = savepv("main");
2482     PL_incgv = gv_HVadd(gv_AVadd(gv_fetchpv("INC",TRUE, SVt_PVAV)));
2483     GvMULTI_on(PL_incgv);
2484     PL_hintgv = gv_fetchpv("\010",TRUE, SVt_PV); /* ^H */
2485     GvMULTI_on(PL_hintgv);
2486     PL_defgv = gv_fetchpv("_",TRUE, SVt_PVAV);
2487     PL_errgv = gv_HVadd(gv_fetchpv("@", TRUE, SVt_PV));
2488     GvMULTI_on(PL_errgv);
2489     PL_replgv = gv_fetchpv("\022", TRUE, SVt_PV); /* ^R */
2490     GvMULTI_on(PL_replgv);
2491     (void)Perl_form(aTHX_ "%240s","");  /* Preallocate temp - for immediate signals. */
2492     sv_grow(ERRSV, 240);        /* Preallocate - for immediate signals. */
2493     sv_setpvn(ERRSV, "", 0);
2494     PL_curstash = PL_defstash;
2495     CopSTASH_set(&PL_compiling, PL_defstash);
2496     PL_debstash = GvHV(gv_fetchpv("DB::", GV_ADDMULTI, SVt_PVHV));
2497     PL_globalstash = GvHV(gv_fetchpv("CORE::GLOBAL::", GV_ADDMULTI, SVt_PVHV));
2498     PL_nullstash = GvHV(gv_fetchpv("<none>::", GV_ADDMULTI, SVt_PVHV));
2499     /* We must init $/ before switches are processed. */
2500     sv_setpvn(get_sv("/", TRUE), "\n", 1);
2501 }
2502
2503 STATIC void
2504 S_open_script(pTHX_ char *scriptname, bool dosearch, SV *sv, int *fdscript)
2505 {
2506     dTHR;
2507
2508     *fdscript = -1;
2509
2510     if (PL_e_script) {
2511         PL_origfilename = savepv("-e");
2512     }
2513     else {
2514         /* if find_script() returns, it returns a malloc()-ed value */
2515         PL_origfilename = scriptname = find_script(scriptname, dosearch, NULL, 1);
2516
2517         if (strnEQ(scriptname, "/dev/fd/", 8) && isDIGIT(scriptname[8]) ) {
2518             char *s = scriptname + 8;
2519             *fdscript = atoi(s);
2520             while (isDIGIT(*s))
2521                 s++;
2522             if (*s) {
2523                 scriptname = savepv(s + 1);
2524                 Safefree(PL_origfilename);
2525                 PL_origfilename = scriptname;
2526             }
2527         }
2528     }
2529
2530 #ifdef USE_ITHREADS
2531     Safefree(CopFILE(PL_curcop));
2532 #else
2533     SvREFCNT_dec(CopFILEGV(PL_curcop));
2534 #endif
2535     CopFILE_set(PL_curcop, PL_origfilename);
2536     if (strEQ(PL_origfilename,"-"))
2537         scriptname = "";
2538     if (*fdscript >= 0) {
2539         PL_rsfp = PerlIO_fdopen(*fdscript,PERL_SCRIPT_MODE);
2540 #if defined(HAS_FCNTL) && defined(F_SETFD)
2541         if (PL_rsfp)
2542             fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,1);  /* ensure close-on-exec */
2543 #endif
2544     }
2545     else if (PL_preprocess) {
2546         char *cpp_cfg = CPPSTDIN;
2547         SV *cpp = newSVpvn("",0);
2548         SV *cmd = NEWSV(0,0);
2549
2550         if (strEQ(cpp_cfg, "cppstdin"))
2551             Perl_sv_catpvf(aTHX_ cpp, "%s/", BIN_EXP);
2552         sv_catpv(cpp, cpp_cfg);
2553
2554         sv_catpvn(sv, "-I", 2);
2555         sv_catpv(sv,PRIVLIB_EXP);
2556
2557 #if defined(MSDOS) || defined(WIN32)
2558         Perl_sv_setpvf(aTHX_ cmd, "\
2559 sed %s -e \"/^[^#]/b\" \
2560  -e \"/^#[      ]*include[      ]/b\" \
2561  -e \"/^#[      ]*define[       ]/b\" \
2562  -e \"/^#[      ]*if[   ]/b\" \
2563  -e \"/^#[      ]*ifdef[        ]/b\" \
2564  -e \"/^#[      ]*ifndef[       ]/b\" \
2565  -e \"/^#[      ]*else/b\" \
2566  -e \"/^#[      ]*elif[         ]/b\" \
2567  -e \"/^#[      ]*undef[        ]/b\" \
2568  -e \"/^#[      ]*endif/b\" \
2569  -e \"s/^#.*//\" \
2570  %s | %"SVf" -C %"SVf" %s",
2571           (PL_doextract ? "-e \"1,/^#/d\n\"" : ""),
2572 #else
2573 #  ifdef __OPEN_VM
2574         Perl_sv_setpvf(aTHX_ cmd, "\
2575 %s %s -e '/^[^#]/b' \
2576  -e '/^#[       ]*include[      ]/b' \
2577  -e '/^#[       ]*define[       ]/b' \
2578  -e '/^#[       ]*if[   ]/b' \
2579  -e '/^#[       ]*ifdef[        ]/b' \
2580  -e '/^#[       ]*ifndef[       ]/b' \
2581  -e '/^#[       ]*else/b' \
2582  -e '/^#[       ]*elif[         ]/b' \
2583  -e '/^#[       ]*undef[        ]/b' \
2584  -e '/^#[       ]*endif/b' \
2585  -e 's/^[       ]*#.*//' \
2586  %s | %"SVf" %"SVf" %s",
2587 #  else
2588         Perl_sv_setpvf(aTHX_ cmd, "\
2589 %s %s -e '/^[^#]/b' \
2590  -e '/^#[       ]*include[      ]/b' \
2591  -e '/^#[       ]*define[       ]/b' \
2592  -e '/^#[       ]*if[   ]/b' \
2593  -e '/^#[       ]*ifdef[        ]/b' \
2594  -e '/^#[       ]*ifndef[       ]/b' \
2595  -e '/^#[       ]*else/b' \
2596  -e '/^#[       ]*elif[         ]/b' \
2597  -e '/^#[       ]*undef[        ]/b' \
2598  -e '/^#[       ]*endif/b' \
2599  -e 's/^[       ]*#.*//' \
2600  %s | %"SVf" -C %"SVf" %s",
2601 #  endif
2602 #ifdef LOC_SED
2603           LOC_SED,
2604 #else
2605           "sed",
2606 #endif
2607           (PL_doextract ? "-e '1,/^#/d\n'" : ""),
2608 #endif
2609           scriptname, cpp, sv, CPPMINUS);
2610         PL_doextract = FALSE;
2611 #ifdef IAMSUID                          /* actually, this is caught earlier */
2612         if (PL_euid != PL_uid && !PL_euid) {    /* if running suidperl */
2613 #ifdef HAS_SETEUID
2614             (void)seteuid(PL_uid);              /* musn't stay setuid root */
2615 #else
2616 #ifdef HAS_SETREUID
2617             (void)setreuid((Uid_t)-1, PL_uid);
2618 #else
2619 #ifdef HAS_SETRESUID
2620             (void)setresuid((Uid_t)-1, PL_uid, (Uid_t)-1);
2621 #else
2622             PerlProc_setuid(PL_uid);
2623 #endif
2624 #endif
2625 #endif
2626             if (PerlProc_geteuid() != PL_uid)
2627                 Perl_croak(aTHX_ "Can't do seteuid!\n");
2628         }
2629 #endif /* IAMSUID */
2630         PL_rsfp = PerlProc_popen(SvPVX(cmd), "r");
2631         SvREFCNT_dec(cmd);
2632         SvREFCNT_dec(cpp);
2633     }
2634     else if (!*scriptname) {
2635         forbid_setid("program input from stdin");
2636         PL_rsfp = PerlIO_stdin();
2637     }
2638     else {
2639         PL_rsfp = PerlIO_open(scriptname,PERL_SCRIPT_MODE);
2640 #if defined(HAS_FCNTL) && defined(F_SETFD)
2641         if (PL_rsfp)
2642             fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,1);  /* ensure close-on-exec */
2643 #endif
2644     }
2645     if (!PL_rsfp) {
2646 #ifdef DOSUID
2647 #ifndef IAMSUID         /* in case script is not readable before setuid */
2648         if (PL_euid &&
2649             PerlLIO_stat(CopFILE(PL_curcop),&PL_statbuf) >= 0 &&
2650             PL_statbuf.st_mode & (S_ISUID|S_ISGID))
2651         {
2652             /* try again */
2653             PerlProc_execv(Perl_form(aTHX_ "%s/sperl"PERL_FS_VER_FMT, BIN_EXP,
2654                                      (int)PERL_REVISION, (int)PERL_VERSION,
2655                                      (int)PERL_SUBVERSION), PL_origargv);
2656             Perl_croak(aTHX_ "Can't do setuid\n");
2657         }
2658 #endif
2659 #endif
2660         Perl_croak(aTHX_ "Can't open perl script \"%s\": %s\n",
2661                    CopFILE(PL_curcop), Strerror(errno));
2662     }
2663 }
2664
2665 /* Mention
2666  * I_SYSSTATVFS HAS_FSTATVFS
2667  * I_SYSMOUNT
2668  * I_STATFS     HAS_FSTATFS     HAS_GETFSSTAT
2669  * I_MNTENT     HAS_GETMNTENT   HAS_HASMNTOPT
2670  * here so that metaconfig picks them up. */
2671
2672 #ifdef IAMSUID
2673 STATIC int
2674 S_fd_on_nosuid_fs(pTHX_ int fd)
2675 {
2676     int check_okay = 0; /* able to do all the required sys/libcalls */
2677     int on_nosuid  = 0; /* the fd is on a nosuid fs */
2678 /*
2679  * Preferred order: fstatvfs(), fstatfs(), ustat()+getmnt(), getmntent().
2680  * fstatvfs() is UNIX98.
2681  * fstatfs() is 4.3 BSD.
2682  * ustat()+getmnt() is pre-4.3 BSD.
2683  * getmntent() is O(number-of-mounted-filesystems) and can hang on
2684  * an irrelevant filesystem while trying to reach the right one.
2685  */
2686
2687 #undef FD_ON_NOSUID_CHECK_OKAY  /* found the syscalls to do the check? */
2688
2689 #   if !defined(FD_ON_NOSUID_CHECK_OKAY) && \
2690         defined(HAS_FSTATVFS)
2691 #   define FD_ON_NOSUID_CHECK_OKAY
2692     struct statvfs stfs;
2693
2694     check_okay = fstatvfs(fd, &stfs) == 0;
2695     on_nosuid  = check_okay && (stfs.f_flag  & ST_NOSUID);
2696 #   endif /* fstatvfs */
2697
2698 #   if !defined(FD_ON_NOSUID_CHECK_OKAY) && \
2699         defined(PERL_MOUNT_NOSUID)      && \
2700         defined(HAS_FSTATFS)            && \
2701         defined(HAS_STRUCT_STATFS)      && \
2702         defined(HAS_STRUCT_STATFS_F_FLAGS)
2703 #   define FD_ON_NOSUID_CHECK_OKAY
2704     struct statfs  stfs;
2705
2706     check_okay = fstatfs(fd, &stfs)  == 0;
2707     on_nosuid  = check_okay && (stfs.f_flags & PERL_MOUNT_NOSUID);
2708 #   endif /* fstatfs */
2709
2710 #   if !defined(FD_ON_NOSUID_CHECK_OKAY) && \
2711         defined(PERL_MOUNT_NOSUID)      && \
2712         defined(HAS_FSTAT)              && \
2713         defined(HAS_USTAT)              && \
2714         defined(HAS_GETMNT)             && \
2715         defined(HAS_STRUCT_FS_DATA)     && \
2716         defined(NOSTAT_ONE)
2717 #   define FD_ON_NOSUID_CHECK_OKAY
2718     struct stat fdst;
2719
2720     if (fstat(fd, &fdst) == 0) {
2721         struct ustat us;
2722         if (ustat(fdst.st_dev, &us) == 0) {
2723             struct fs_data fsd;
2724             /* NOSTAT_ONE here because we're not examining fields which
2725              * vary between that case and STAT_ONE. */
2726             if (getmnt((int*)0, &fsd, (int)0, NOSTAT_ONE, us.f_fname) == 0) {
2727                 size_t cmplen = sizeof(us.f_fname);
2728                 if (sizeof(fsd.fd_req.path) < cmplen)
2729                     cmplen = sizeof(fsd.fd_req.path);
2730                 if (strnEQ(fsd.fd_req.path, us.f_fname, cmplen) &&
2731                     fdst.st_dev == fsd.fd_req.dev) {
2732                         check_okay = 1;
2733                         on_nosuid = fsd.fd_req.flags & PERL_MOUNT_NOSUID;
2734                     }
2735                 }
2736             }
2737         }
2738     }
2739 #   endif /* fstat+ustat+getmnt */
2740
2741 #   if !defined(FD_ON_NOSUID_CHECK_OKAY) && \
2742         defined(HAS_GETMNTENT)          && \
2743         defined(HAS_HASMNTOPT)          && \
2744         defined(MNTOPT_NOSUID)
2745 #   define FD_ON_NOSUID_CHECK_OKAY
2746     FILE                *mtab = fopen("/etc/mtab", "r");
2747     struct mntent       *entry;
2748     struct stat         stb, fsb;
2749
2750     if (mtab && (fstat(fd, &stb) == 0)) {
2751         while (entry = getmntent(mtab)) {
2752             if (stat(entry->mnt_dir, &fsb) == 0
2753                 && fsb.st_dev == stb.st_dev)
2754             {
2755                 /* found the filesystem */
2756                 check_okay = 1;
2757                 if (hasmntopt(entry, MNTOPT_NOSUID))
2758                     on_nosuid = 1;
2759                 break;
2760             } /* A single fs may well fail its stat(). */
2761         }
2762     }
2763     if (mtab)
2764         fclose(mtab);
2765 #   endif /* getmntent+hasmntopt */
2766
2767     if (!check_okay)
2768         Perl_croak(aTHX_ "Can't check filesystem of script \"%s\" for nosuid", PL_origfilename);
2769     return on_nosuid;
2770 }
2771 #endif /* IAMSUID */
2772
2773 STATIC void
2774 S_validate_suid(pTHX_ char *validarg, char *scriptname, int fdscript)
2775 {
2776 #ifdef IAMSUID
2777     int which;
2778 #endif
2779
2780     /* do we need to emulate setuid on scripts? */
2781
2782     /* This code is for those BSD systems that have setuid #! scripts disabled
2783      * in the kernel because of a security problem.  Merely defining DOSUID
2784      * in perl will not fix that problem, but if you have disabled setuid
2785      * scripts in the kernel, this will attempt to emulate setuid and setgid
2786      * on scripts that have those now-otherwise-useless bits set.  The setuid
2787      * root version must be called suidperl or sperlN.NNN.  If regular perl
2788      * discovers that it has opened a setuid script, it calls suidperl with
2789      * the same argv that it had.  If suidperl finds that the script it has
2790      * just opened is NOT setuid root, it sets the effective uid back to the
2791      * uid.  We don't just make perl setuid root because that loses the
2792      * effective uid we had before invoking perl, if it was different from the
2793      * uid.
2794      *
2795      * DOSUID must be defined in both perl and suidperl, and IAMSUID must
2796      * be defined in suidperl only.  suidperl must be setuid root.  The
2797      * Configure script will set this up for you if you want it.
2798      */
2799
2800 #ifdef DOSUID
2801     dTHR;
2802     char *s, *s2;
2803
2804     if (PerlLIO_fstat(PerlIO_fileno(PL_rsfp),&PL_statbuf) < 0)  /* normal stat is insecure */
2805         Perl_croak(aTHX_ "Can't stat script \"%s\"",PL_origfilename);
2806     if (fdscript < 0 && PL_statbuf.st_mode & (S_ISUID|S_ISGID)) {
2807         I32 len;
2808         STRLEN n_a;
2809
2810 #ifdef IAMSUID
2811 #ifndef HAS_SETREUID
2812         /* On this access check to make sure the directories are readable,
2813          * there is actually a small window that the user could use to make
2814          * filename point to an accessible directory.  So there is a faint
2815          * chance that someone could execute a setuid script down in a
2816          * non-accessible directory.  I don't know what to do about that.
2817          * But I don't think it's too important.  The manual lies when
2818          * it says access() is useful in setuid programs.
2819          */
2820         if (PerlLIO_access(CopFILE(PL_curcop),1)) /*double check*/
2821             Perl_croak(aTHX_ "Permission denied");
2822 #else
2823         /* If we can swap euid and uid, then we can determine access rights
2824          * with a simple stat of the file, and then compare device and
2825          * inode to make sure we did stat() on the same file we opened.
2826          * Then we just have to make sure he or she can execute it.
2827          */
2828         {
2829             struct stat tmpstatbuf;
2830
2831             if (
2832 #ifdef HAS_SETREUID
2833                 setreuid(PL_euid,PL_uid) < 0
2834 #else
2835 # if HAS_SETRESUID
2836                 setresuid(PL_euid,PL_uid,(Uid_t)-1) < 0
2837 # endif
2838 #endif
2839                 || PerlProc_getuid() != PL_euid || PerlProc_geteuid() != PL_uid)
2840                 Perl_croak(aTHX_ "Can't swap uid and euid");    /* really paranoid */
2841             if (PerlLIO_stat(CopFILE(PL_curcop),&tmpstatbuf) < 0)
2842                 Perl_croak(aTHX_ "Permission denied");  /* testing full pathname here */
2843 #if defined(IAMSUID) && !defined(NO_NOSUID_CHECK)
2844             if (fd_on_nosuid_fs(PerlIO_fileno(PL_rsfp)))
2845                 Perl_croak(aTHX_ "Permission denied");
2846 #endif
2847             if (tmpstatbuf.st_dev != PL_statbuf.st_dev ||
2848                 tmpstatbuf.st_ino != PL_statbuf.st_ino) {
2849                 (void)PerlIO_close(PL_rsfp);
2850                 if (PL_rsfp = PerlProc_popen("/bin/mail root","w")) {   /* heh, heh */
2851                     PerlIO_printf(PL_rsfp,
2852 "User %"Uid_t_f" tried to run dev %ld ino %ld in place of dev %ld ino %ld!\n\
2853 (Filename of set-id script was %s, uid %"Uid_t_f" gid %"Gid_t_f".)\n\nSincerely,\nperl\n",
2854                         PL_uid,(long)tmpstatbuf.st_dev, (long)tmpstatbuf.st_ino,
2855                         (long)PL_statbuf.st_dev, (long)PL_statbuf.st_ino,
2856                         CopFILE(PL_curcop),
2857                         PL_statbuf.st_uid, PL_statbuf.st_gid);
2858                     (void)PerlProc_pclose(PL_rsfp);
2859                 }
2860                 Perl_croak(aTHX_ "Permission denied\n");
2861             }
2862             if (
2863 #ifdef HAS_SETREUID
2864               setreuid(PL_uid,PL_euid) < 0
2865 #else
2866 # if defined(HAS_SETRESUID)
2867               setresuid(PL_uid,PL_euid,(Uid_t)-1) < 0
2868 # endif
2869 #endif
2870               || PerlProc_getuid() != PL_uid || PerlProc_geteuid() != PL_euid)
2871                 Perl_croak(aTHX_ "Can't reswap uid and euid");
2872             if (!cando(S_IXUSR,FALSE,&PL_statbuf))              /* can real uid exec? */
2873                 Perl_croak(aTHX_ "Permission denied\n");
2874         }
2875 #endif /* HAS_SETREUID */
2876 #endif /* IAMSUID */
2877
2878         if (!S_ISREG(PL_statbuf.st_mode))
2879             Perl_croak(aTHX_ "Permission denied");
2880         if (PL_statbuf.st_mode & S_IWOTH)
2881             Perl_croak(aTHX_ "Setuid/gid script is writable by world");
2882         PL_doswitches = FALSE;          /* -s is insecure in suid */
2883         CopLINE_inc(PL_curcop);
2884         if (sv_gets(PL_linestr, PL_rsfp, 0) == Nullch ||
2885           strnNE(SvPV(PL_linestr,n_a),"#!",2) ) /* required even on Sys V */
2886             Perl_croak(aTHX_ "No #! line");
2887         s = SvPV(PL_linestr,n_a)+2;
2888         if (*s == ' ') s++;
2889         while (!isSPACE(*s)) s++;
2890         for (s2 = s;  (s2 > SvPV(PL_linestr,n_a)+2 &&
2891                        (isDIGIT(s2[-1]) || strchr("._-", s2[-1])));  s2--) ;
2892         if (strnNE(s2-4,"perl",4) && strnNE(s-9,"perl",4))  /* sanity check */
2893             Perl_croak(aTHX_ "Not a perl script");
2894         while (*s == ' ' || *s == '\t') s++;
2895         /*
2896          * #! arg must be what we saw above.  They can invoke it by
2897          * mentioning suidperl explicitly, but they may not add any strange
2898          * arguments beyond what #! says if they do invoke suidperl that way.
2899          */
2900         len = strlen(validarg);
2901         if (strEQ(validarg," PHOOEY ") ||
2902             strnNE(s,validarg,len) || !isSPACE(s[len]))
2903             Perl_croak(aTHX_ "Args must match #! line");
2904
2905 #ifndef IAMSUID
2906         if (PL_euid != PL_uid && (PL_statbuf.st_mode & S_ISUID) &&
2907             PL_euid == PL_statbuf.st_uid)
2908             if (!PL_do_undump)
2909                 Perl_croak(aTHX_ "YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
2910 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
2911 #endif /* IAMSUID */
2912
2913         if (PL_euid) {  /* oops, we're not the setuid root perl */
2914             (void)PerlIO_close(PL_rsfp);
2915 #ifndef IAMSUID
2916             /* try again */
2917             PerlProc_execv(Perl_form(aTHX_ "%s/sperl"PERL_FS_VER_FMT, BIN_EXP,
2918                                      (int)PERL_REVISION, (int)PERL_VERSION,
2919                                      (int)PERL_SUBVERSION), PL_origargv);
2920 #endif
2921             Perl_croak(aTHX_ "Can't do setuid\n");
2922         }
2923
2924         if (PL_statbuf.st_mode & S_ISGID && PL_statbuf.st_gid != PL_egid) {
2925 #ifdef HAS_SETEGID
2926             (void)setegid(PL_statbuf.st_gid);
2927 #else
2928 #ifdef HAS_SETREGID
2929            (void)setregid((Gid_t)-1,PL_statbuf.st_gid);
2930 #else
2931 #ifdef HAS_SETRESGID
2932            (void)setresgid((Gid_t)-1,PL_statbuf.st_gid,(Gid_t)-1);
2933 #else
2934             PerlProc_setgid(PL_statbuf.st_gid);
2935 #endif
2936 #endif
2937 #endif
2938             if (PerlProc_getegid() != PL_statbuf.st_gid)
2939                 Perl_croak(aTHX_ "Can't do setegid!\n");
2940         }
2941         if (PL_statbuf.st_mode & S_ISUID) {
2942             if (PL_statbuf.st_uid != PL_euid)
2943 #ifdef HAS_SETEUID
2944                 (void)seteuid(PL_statbuf.st_uid);       /* all that for this */
2945 #else
2946 #ifdef HAS_SETREUID
2947                 (void)setreuid((Uid_t)-1,PL_statbuf.st_uid);
2948 #else
2949 #ifdef HAS_SETRESUID
2950                 (void)setresuid((Uid_t)-1,PL_statbuf.st_uid,(Uid_t)-1);
2951 #else
2952                 PerlProc_setuid(PL_statbuf.st_uid);
2953 #endif
2954 #endif
2955 #endif
2956             if (PerlProc_geteuid() != PL_statbuf.st_uid)
2957                 Perl_croak(aTHX_ "Can't do seteuid!\n");
2958         }
2959         else if (PL_uid) {                      /* oops, mustn't run as root */
2960 #ifdef HAS_SETEUID
2961           (void)seteuid((Uid_t)PL_uid);
2962 #else
2963 #ifdef HAS_SETREUID
2964           (void)setreuid((Uid_t)-1,(Uid_t)PL_uid);
2965 #else
2966 #ifdef HAS_SETRESUID
2967           (void)setresuid((Uid_t)-1,(Uid_t)PL_uid,(Uid_t)-1);
2968 #else
2969           PerlProc_setuid((Uid_t)PL_uid);
2970 #endif
2971 #endif
2972 #endif
2973             if (PerlProc_geteuid() != PL_uid)
2974                 Perl_croak(aTHX_ "Can't do seteuid!\n");
2975         }
2976         init_ids();
2977         if (!cando(S_IXUSR,TRUE,&PL_statbuf))
2978             Perl_croak(aTHX_ "Permission denied\n");    /* they can't do this */
2979     }
2980 #ifdef IAMSUID
2981     else if (PL_preprocess)
2982         Perl_croak(aTHX_ "-P not allowed for setuid/setgid script\n");
2983     else if (fdscript >= 0)
2984         Perl_croak(aTHX_ "fd script not allowed in suidperl\n");
2985     else
2986         Perl_croak(aTHX_ "Script is not setuid/setgid in suidperl\n");
2987
2988     /* We absolutely must clear out any saved ids here, so we */
2989     /* exec the real perl, substituting fd script for scriptname. */
2990     /* (We pass script name as "subdir" of fd, which perl will grok.) */
2991     PerlIO_rewind(PL_rsfp);
2992     PerlLIO_lseek(PerlIO_fileno(PL_rsfp),(Off_t)0,0);  /* just in case rewind didn't */
2993     for (which = 1; PL_origargv[which] && PL_origargv[which] != scriptname; which++) ;
2994     if (!PL_origargv[which])
2995         Perl_croak(aTHX_ "Permission denied");
2996     PL_origargv[which] = savepv(Perl_form(aTHX_ "/dev/fd/%d/%s",
2997                                   PerlIO_fileno(PL_rsfp), PL_origargv[which]));
2998 #if defined(HAS_FCNTL) && defined(F_SETFD)
2999     fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,0);    /* ensure no close-on-exec */
3000 #endif
3001     PerlProc_execv(Perl_form(aTHX_ "%s/perl"PERL_FS_VER_FMT, BIN_EXP,
3002                              (int)PERL_REVISION, (int)PERL_VERSION,
3003                              (int)PERL_SUBVERSION), PL_origargv);/* try again */
3004     Perl_croak(aTHX_ "Can't do setuid\n");
3005 #endif /* IAMSUID */
3006 #else /* !DOSUID */
3007     if (PL_euid != PL_uid || PL_egid != PL_gid) {       /* (suidperl doesn't exist, in fact) */
3008 #ifndef SETUID_SCRIPTS_ARE_SECURE_NOW
3009         dTHR;
3010         PerlLIO_fstat(PerlIO_fileno(PL_rsfp),&PL_statbuf);      /* may be either wrapped or real suid */
3011         if ((PL_euid != PL_uid && PL_euid == PL_statbuf.st_uid && PL_statbuf.st_mode & S_ISUID)
3012             ||
3013             (PL_egid != PL_gid && PL_egid == PL_statbuf.st_gid && PL_statbuf.st_mode & S_ISGID)
3014            )
3015             if (!PL_do_undump)
3016                 Perl_croak(aTHX_ "YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
3017 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
3018 #endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
3019         /* not set-id, must be wrapped */
3020     }
3021 #endif /* DOSUID */
3022 }
3023
3024 STATIC void
3025 S_find_beginning(pTHX)
3026 {
3027     register char *s, *s2;
3028
3029     /* skip forward in input to the real script? */
3030
3031     forbid_setid("-x");
3032 #ifdef MACOS_TRADITIONAL
3033     /* Since the Mac OS does not honor !# arguments for us, we do it ourselves */
3034
3035     while (PL_doextract || gMacPerl_AlwaysExtract) {
3036         if ((s = sv_gets(PL_linestr, PL_rsfp, 0)) == Nullch) {
3037             if (!gMacPerl_AlwaysExtract)
3038                 Perl_croak(aTHX_ "No Perl script found in input\n");
3039
3040             if (PL_doextract)                   /* require explicit override ? */
3041                 if (!OverrideExtract(PL_origfilename))
3042                     Perl_croak(aTHX_ "User aborted script\n");
3043                 else
3044                     PL_doextract = FALSE;
3045
3046             /* Pater peccavi, file does not have #! */
3047             PerlIO_rewind(PL_rsfp);
3048
3049             break;
3050         }
3051 #else
3052     while (PL_doextract) {
3053         if ((s = sv_gets(PL_linestr, PL_rsfp, 0)) == Nullch)
3054             Perl_croak(aTHX_ "No Perl script found in input\n");
3055 #endif
3056         if (*s == '#' && s[1] == '!' && (s = instr(s,"perl"))) {
3057             PerlIO_ungetc(PL_rsfp, '\n');               /* to keep line count right */
3058             PL_doextract = FALSE;
3059             while (*s && !(isSPACE (*s) || *s == '#')) s++;
3060             s2 = s;
3061             while (*s == ' ' || *s == '\t') s++;
3062             if (*s++ == '-') {
3063                 while (isDIGIT(s2[-1]) || strchr("-._", s2[-1])) s2--;
3064                 if (strnEQ(s2-4,"perl",4))
3065                     /*SUPPRESS 530*/
3066                     while ((s = moreswitches(s)))
3067                         ;
3068             }
3069         }
3070     }
3071 }
3072
3073
3074 STATIC void
3075 S_init_ids(pTHX)
3076 {
3077     PL_uid = PerlProc_getuid();
3078     PL_euid = PerlProc_geteuid();
3079     PL_gid = PerlProc_getgid();
3080     PL_egid = PerlProc_getegid();
3081 #ifdef VMS
3082     PL_uid |= PL_gid << 16;
3083     PL_euid |= PL_egid << 16;
3084 #endif
3085     PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
3086 }
3087
3088 STATIC void
3089 S_forbid_setid(pTHX_ char *s)
3090 {
3091     if (PL_euid != PL_uid)
3092         Perl_croak(aTHX_ "No %s allowed while running setuid", s);
3093     if (PL_egid != PL_gid)
3094         Perl_croak(aTHX_ "No %s allowed while running setgid", s);
3095 }
3096
3097 void
3098 Perl_init_debugger(pTHX)
3099 {
3100     dTHR;
3101     HV *ostash = PL_curstash;
3102
3103     PL_curstash = PL_debstash;
3104     PL_dbargs = GvAV(gv_AVadd((gv_fetchpv("args", GV_ADDMULTI, SVt_PVAV))));
3105     AvREAL_off(PL_dbargs);
3106     PL_DBgv = gv_fetchpv("DB", GV_ADDMULTI, SVt_PVGV);
3107     PL_DBline = gv_fetchpv("dbline", GV_ADDMULTI, SVt_PVAV);
3108     PL_DBsub = gv_HVadd(gv_fetchpv("sub", GV_ADDMULTI, SVt_PVHV));
3109     sv_upgrade(GvSV(PL_DBsub), SVt_IV); /* IVX accessed if PERLDB_SUB_NN */
3110     PL_DBsingle = GvSV((gv_fetchpv("single", GV_ADDMULTI, SVt_PV)));
3111     sv_setiv(PL_DBsingle, 0);
3112     PL_DBtrace = GvSV((gv_fetchpv("trace", GV_ADDMULTI, SVt_PV)));
3113     sv_setiv(PL_DBtrace, 0);
3114     PL_DBsignal = GvSV((gv_fetchpv("signal", GV_ADDMULTI, SVt_PV)));
3115     sv_setiv(PL_DBsignal, 0);
3116     PL_curstash = ostash;
3117 }
3118
3119 #ifndef STRESS_REALLOC
3120 #define REASONABLE(size) (size)
3121 #else
3122 #define REASONABLE(size) (1) /* unreasonable */
3123 #endif
3124
3125 void
3126 Perl_init_stacks(pTHX)
3127 {
3128     /* start with 128-item stack and 8K cxstack */
3129     PL_curstackinfo = new_stackinfo(REASONABLE(128),
3130                                  REASONABLE(8192/sizeof(PERL_CONTEXT) - 1));
3131     PL_curstackinfo->si_type = PERLSI_MAIN;
3132     PL_curstack = PL_curstackinfo->si_stack;
3133     PL_mainstack = PL_curstack;         /* remember in case we switch stacks */
3134
3135     PL_stack_base = AvARRAY(PL_curstack);
3136     PL_stack_sp = PL_stack_base;
3137     PL_stack_max = PL_stack_base + AvMAX(PL_curstack);
3138
3139     New(50,PL_tmps_stack,REASONABLE(128),SV*);
3140     PL_tmps_floor = -1;
3141     PL_tmps_ix = -1;
3142     PL_tmps_max = REASONABLE(128);
3143
3144     New(54,PL_markstack,REASONABLE(32),I32);
3145     PL_markstack_ptr = PL_markstack;
3146     PL_markstack_max = PL_markstack + REASONABLE(32);
3147
3148     SET_MARK_OFFSET;
3149
3150     New(54,PL_scopestack,REASONABLE(32),I32);
3151     PL_scopestack_ix = 0;
3152     PL_scopestack_max = REASONABLE(32);
3153
3154     New(54,PL_savestack,REASONABLE(128),ANY);
3155     PL_savestack_ix = 0;
3156     PL_savestack_max = REASONABLE(128);
3157
3158     New(54,PL_retstack,REASONABLE(16),OP*);
3159     PL_retstack_ix = 0;
3160     PL_retstack_max = REASONABLE(16);
3161 }
3162
3163 #undef REASONABLE
3164
3165 STATIC void
3166 S_nuke_stacks(pTHX)
3167 {
3168     dTHR;
3169     while (PL_curstackinfo->si_next)
3170         PL_curstackinfo = PL_curstackinfo->si_next;
3171     while (PL_curstackinfo) {
3172         PERL_SI *p = PL_curstackinfo->si_prev;
3173         /* curstackinfo->si_stack got nuked by sv_free_arenas() */
3174         Safefree(PL_curstackinfo->si_cxstack);
3175         Safefree(PL_curstackinfo);
3176         PL_curstackinfo = p;
3177     }
3178     Safefree(PL_tmps_stack);
3179     Safefree(PL_markstack);
3180     Safefree(PL_scopestack);
3181     Safefree(PL_savestack);
3182     Safefree(PL_retstack);
3183 }
3184
3185 #ifndef PERL_OBJECT
3186 static PerlIO *tmpfp;  /* moved outside init_lexer() because of UNICOS bug */
3187 #endif
3188
3189 STATIC void
3190 S_init_lexer(pTHX)
3191 {
3192 #ifdef PERL_OBJECT
3193         PerlIO *tmpfp;
3194 #endif
3195     tmpfp = PL_rsfp;
3196     PL_rsfp = Nullfp;
3197     lex_start(PL_linestr);
3198     PL_rsfp = tmpfp;
3199     PL_subname = newSVpvn("main",4);
3200 }
3201
3202 STATIC void
3203 S_init_predump_symbols(pTHX)
3204 {
3205     dTHR;
3206     GV *tmpgv;
3207     IO *io;
3208
3209     sv_setpvn(get_sv("\"", TRUE), " ", 1);
3210     PL_stdingv = gv_fetchpv("STDIN",TRUE, SVt_PVIO);
3211     GvMULTI_on(PL_stdingv);
3212     io = GvIOp(PL_stdingv);
3213     IoIFP(io) = PerlIO_stdin();
3214     tmpgv = gv_fetchpv("stdin",TRUE, SVt_PV);
3215     GvMULTI_on(tmpgv);
3216     GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io);
3217
3218     tmpgv = gv_fetchpv("STDOUT",TRUE, SVt_PVIO);
3219     GvMULTI_on(tmpgv);
3220     io = GvIOp(tmpgv);
3221     IoOFP(io) = IoIFP(io) = PerlIO_stdout();
3222     setdefout(tmpgv);
3223     tmpgv = gv_fetchpv("stdout",TRUE, SVt_PV);
3224     GvMULTI_on(tmpgv);
3225     GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io);
3226
3227     PL_stderrgv = gv_fetchpv("STDERR",TRUE, SVt_PVIO);
3228     GvMULTI_on(PL_stderrgv);
3229     io = GvIOp(PL_stderrgv);
3230     IoOFP(io) = IoIFP(io) = PerlIO_stderr();
3231     tmpgv = gv_fetchpv("stderr",TRUE, SVt_PV);
3232     GvMULTI_on(tmpgv);
3233     GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io);
3234
3235     PL_statname = NEWSV(66,0);          /* last filename we did stat on */
3236
3237     if (PL_osname)
3238         Safefree(PL_osname);
3239     PL_osname = savepv(OSNAME);
3240 }
3241
3242 STATIC void
3243 S_init_postdump_symbols(pTHX_ register int argc, register char **argv, register char **env)
3244 {
3245     dTHR;
3246     char *s;
3247     SV *sv;
3248     GV* tmpgv;
3249
3250     argc--,argv++;      /* skip name of script */
3251     if (PL_doswitches) {
3252         for (; argc > 0 && **argv == '-'; argc--,argv++) {
3253             if (!argv[0][1])
3254                 break;
3255             if (argv[0][1] == '-' && !argv[0][2]) {
3256                 argc--,argv++;
3257                 break;
3258             }
3259             if ((s = strchr(argv[0], '='))) {
3260                 *s++ = '\0';
3261                 sv_setpv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),s);
3262             }
3263             else
3264                 sv_setiv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),1);
3265         }
3266     }
3267     PL_toptarget = NEWSV(0,0);
3268     sv_upgrade(PL_toptarget, SVt_PVFM);
3269     sv_setpvn(PL_toptarget, "", 0);
3270     PL_bodytarget = NEWSV(0,0);
3271     sv_upgrade(PL_bodytarget, SVt_PVFM);
3272     sv_setpvn(PL_bodytarget, "", 0);
3273     PL_formtarget = PL_bodytarget;
3274
3275     TAINT;
3276     if ((tmpgv = gv_fetchpv("0",TRUE, SVt_PV))) {
3277 #ifdef MACOS_TRADITIONAL
3278         /* $0 is not majick on a Mac */
3279         sv_setpv(GvSV(tmpgv),MacPerl_MPWFileName(PL_origfilename));
3280 #else
3281         sv_setpv(GvSV(tmpgv),PL_origfilename);
3282         magicname("0", "0", 1);
3283 #endif
3284     }
3285     if ((tmpgv = gv_fetchpv("\030",TRUE, SVt_PV)))
3286 #ifdef OS2
3287         sv_setpv(GvSV(tmpgv), os2_execname(aTHX));
3288 #else
3289         sv_setpv(GvSV(tmpgv),PL_origargv[0]);
3290 #endif
3291     if ((PL_argvgv = gv_fetchpv("ARGV",TRUE, SVt_PVAV))) {
3292         GvMULTI_on(PL_argvgv);
3293         (void)gv_AVadd(PL_argvgv);
3294         av_clear(GvAVn(PL_argvgv));
3295         for (; argc > 0; argc--,argv++) {
3296             SV *sv = newSVpv(argv[0],0);
3297             av_push(GvAVn(PL_argvgv),sv);
3298             if (PL_widesyscalls)
3299                 (void)sv_utf8_decode(sv);
3300         }
3301     }
3302     if ((PL_envgv = gv_fetchpv("ENV",TRUE, SVt_PVHV))) {
3303         HV *hv;
3304         GvMULTI_on(PL_envgv);
3305         hv = GvHVn(PL_envgv);
3306         hv_magic(hv, PL_envgv, 'E');
3307 #if !defined( VMS) && !defined(EPOC) && !defined(MACOS_TRADITIONAL) /* VMS doesn't have environ array */
3308         /* Note that if the supplied env parameter is actually a copy
3309            of the global environ then it may now point to free'd memory
3310            if the environment has been modified since. To avoid this
3311            problem we treat env==NULL as meaning 'use the default'
3312         */
3313         if (!env)
3314             env = environ;
3315         if (env != environ)
3316             environ[0] = Nullch;
3317         for (; *env; env++) {
3318             if (!(s = strchr(*env,'=')))
3319                 continue;
3320             *s++ = '\0';
3321 #if defined(MSDOS)
3322             (void)strupr(*env);
3323 #endif
3324             sv = newSVpv(s--,0);
3325             (void)hv_store(hv, *env, s - *env, sv, 0);
3326             *s = '=';
3327 #if defined(__BORLANDC__) && defined(USE_WIN32_RTL_ENV)
3328             /* Sins of the RTL. See note in my_setenv(). */
3329             (void)PerlEnv_putenv(savepv(*env));
3330 #endif
3331         }
3332 #endif
3333 #ifdef DYNAMIC_ENV_FETCH
3334         HvNAME(hv) = savepv(ENV_HV_NAME);
3335 #endif
3336     }
3337     TAINT_NOT;
3338     if ((tmpgv = gv_fetchpv("$",TRUE, SVt_PV)))
3339         sv_setiv(GvSV(tmpgv), (IV)PerlProc_getpid());
3340 }
3341
3342 STATIC void
3343 S_init_perllib(pTHX)
3344 {
3345     char *s;
3346     if (!PL_tainting) {
3347 #ifndef VMS
3348         s = PerlEnv_getenv("PERL5LIB");
3349         if (s)
3350             incpush(s, TRUE, TRUE);
3351         else
3352             incpush(PerlEnv_getenv("PERLLIB"), FALSE, FALSE);
3353 #else /* VMS */
3354         /* Treat PERL5?LIB as a possible search list logical name -- the
3355          * "natural" VMS idiom for a Unix path string.  We allow each
3356          * element to be a set of |-separated directories for compatibility.
3357          */
3358         char buf[256];
3359         int idx = 0;
3360         if (my_trnlnm("PERL5LIB",buf,0))
3361             do { incpush(buf,TRUE,TRUE); } while (my_trnlnm("PERL5LIB",buf,++idx));
3362         else
3363             while (my_trnlnm("PERLLIB",buf,idx++)) incpush(buf,FALSE,FALSE);
3364 #endif /* VMS */
3365     }
3366
3367 /* Use the ~-expanded versions of APPLLIB (undocumented),
3368     ARCHLIB PRIVLIB SITEARCH SITELIB VENDORARCH and VENDORLIB
3369 */
3370 #ifdef APPLLIB_EXP
3371     incpush(APPLLIB_EXP, TRUE, TRUE);
3372 #endif
3373
3374 #ifdef ARCHLIB_EXP
3375     incpush(ARCHLIB_EXP, FALSE, FALSE);
3376 #endif
3377 #ifdef MACOS_TRADITIONAL
3378     {
3379         struct stat tmpstatbuf;
3380         SV * privdir = NEWSV(55, 0);
3381         char * macperl = PerlEnv_getenv("MACPERL");
3382
3383         if (!macperl)
3384             macperl = "";
3385
3386         Perl_sv_setpvf(aTHX_ privdir, "%slib:", macperl);
3387         if (PerlLIO_stat(SvPVX(privdir), &tmpstatbuf) >= 0 && S_ISDIR(tmpstatbuf.st_mode))
3388             incpush(SvPVX(privdir), TRUE, FALSE);
3389         Perl_sv_setpvf(aTHX_ privdir, "%ssite_perl:", macperl);
3390         if (PerlLIO_stat(SvPVX(privdir), &tmpstatbuf) >= 0 && S_ISDIR(tmpstatbuf.st_mode))
3391             incpush(SvPVX(privdir), TRUE, FALSE);
3392
3393         SvREFCNT_dec(privdir);
3394     }
3395     if (!PL_tainting)
3396         incpush(":", FALSE, FALSE);
3397 #else
3398 #ifndef PRIVLIB_EXP
3399 #  define PRIVLIB_EXP "/usr/local/lib/perl5:/usr/local/lib/perl"
3400 #endif
3401 #if defined(WIN32)
3402     incpush(PRIVLIB_EXP, TRUE, FALSE);
3403 #else
3404     incpush(PRIVLIB_EXP, FALSE, FALSE);
3405 #endif
3406
3407 #ifdef SITEARCH_EXP
3408     /* sitearch is always relative to sitelib on Windows for
3409      * DLL-based path intuition to work correctly */
3410 #  if !defined(WIN32)
3411     incpush(SITEARCH_EXP, FALSE, FALSE);
3412 #  endif
3413 #endif
3414
3415 #ifdef SITELIB_EXP
3416 #  if defined(WIN32)
3417     incpush(SITELIB_EXP, TRUE, FALSE);  /* this picks up sitearch as well */
3418 #  else
3419     incpush(SITELIB_EXP, FALSE, FALSE);
3420 #  endif
3421 #endif
3422
3423 #ifdef SITELIB_STEM /* Search for version-specific dirs below here */
3424     incpush(SITELIB_STEM, FALSE, TRUE);
3425 #endif
3426
3427 #ifdef PERL_VENDORARCH_EXP
3428     /* vendorarch is always relative to vendorlib on Windows for
3429      * DLL-based path intuition to work correctly */
3430 #  if !defined(WIN32)
3431     incpush(PERL_VENDORARCH_EXP, FALSE, FALSE);
3432 #  endif
3433 #endif
3434
3435 #ifdef PERL_VENDORLIB_EXP
3436 #  if defined(WIN32)
3437     incpush(PERL_VENDORLIB_EXP, TRUE, FALSE);   /* this picks up vendorarch as well */
3438 #  else
3439     incpush(PERL_VENDORLIB_EXP, FALSE, FALSE);
3440 #  endif
3441 #endif
3442
3443 #ifdef PERL_VENDORLIB_STEM /* Search for version-specific dirs below here */
3444     incpush(PERL_VENDORLIB_STEM, FALSE, TRUE);
3445 #endif
3446
3447 #ifdef PERL_OTHERLIBDIRS
3448     incpush(PERL_OTHERLIBDIRS, TRUE, TRUE);
3449 #endif
3450
3451     if (!PL_tainting)
3452         incpush(".", FALSE, FALSE);
3453 #endif /* MACOS_TRADITIONAL */
3454 }
3455
3456 #if defined(DOSISH)
3457 #    define PERLLIB_SEP ';'
3458 #else
3459 #  if defined(VMS)
3460 #    define PERLLIB_SEP '|'
3461 #  else
3462 #    if defined(MACOS_TRADITIONAL)
3463 #      define PERLLIB_SEP ','
3464 #    else
3465 #      define PERLLIB_SEP ':'
3466 #    endif
3467 #  endif
3468 #endif
3469 #ifndef PERLLIB_MANGLE
3470 #  define PERLLIB_MANGLE(s,n) (s)
3471 #endif
3472
3473 STATIC void
3474 S_incpush(pTHX_ char *p, int addsubdirs, int addoldvers)
3475 {
3476     SV *subdir = Nullsv;
3477
3478     if (!p || !*p)
3479         return;
3480
3481     if (addsubdirs || addoldvers) {
3482         subdir = sv_newmortal();
3483     }
3484
3485     /* Break at all separators */
3486     while (p && *p) {
3487         SV *libdir = NEWSV(55,0);
3488         char *s;
3489
3490         /* skip any consecutive separators */
3491         while ( *p == PERLLIB_SEP ) {
3492             /* Uncomment the next line for PATH semantics */
3493             /* av_push(GvAVn(PL_incgv), newSVpvn(".", 1)); */
3494             p++;
3495         }
3496
3497         if ( (s = strchr(p, PERLLIB_SEP)) != Nullch ) {
3498             sv_setpvn(libdir, PERLLIB_MANGLE(p, (STRLEN)(s - p)),
3499                       (STRLEN)(s - p));
3500             p = s + 1;
3501         }
3502         else {
3503             sv_setpv(libdir, PERLLIB_MANGLE(p, 0));
3504             p = Nullch; /* break out */
3505         }
3506 #ifdef MACOS_TRADITIONAL
3507         if (!strchr(SvPVX(libdir), ':'))
3508             sv_insert(libdir, 0, 0, ":", 1);
3509         if (SvPVX(libdir)[SvCUR(libdir)-1] != ':')
3510             sv_catpv(libdir, ":");
3511 #endif
3512
3513         /*
3514          * BEFORE pushing libdir onto @INC we may first push version- and
3515          * archname-specific sub-directories.
3516          */
3517         if (addsubdirs || addoldvers) {
3518 #ifdef PERL_INC_VERSION_LIST
3519             /* Configure terminates PERL_INC_VERSION_LIST with a NULL */
3520             const char *incverlist[] = { PERL_INC_VERSION_LIST };
3521             const char **incver;
3522 #endif
3523             struct stat tmpstatbuf;
3524 #ifdef VMS
3525             char *unix;
3526             STRLEN len;
3527
3528             if ((unix = tounixspec_ts(SvPV(libdir,len),Nullch)) != Nullch) {
3529                 len = strlen(unix);
3530                 while (unix[len-1] == '/') len--;  /* Cosmetic */
3531                 sv_usepvn(libdir,unix,len);
3532             }
3533             else
3534                 PerlIO_printf(Perl_error_log,
3535                               "Failed to unixify @INC element \"%s\"\n",
3536                               SvPV(libdir,len));
3537 #endif
3538             if (addsubdirs) {
3539 #ifdef MACOS_TRADITIONAL
3540 #define PERL_AV_SUFFIX_FMT      ""
3541 #define PERL_ARCH_FMT           ":%s"
3542 #else
3543 #define PERL_AV_SUFFIX_FMT      "/"
3544 #define PERL_ARCH_FMT           "/%s"
3545 #endif
3546                 /* .../version/archname if -d .../version/archname */
3547                 Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_AV_SUFFIX_FMT PERL_FS_VER_FMT PERL_ARCH_FMT,
3548                                 libdir,
3549                                (int)PERL_REVISION, (int)PERL_VERSION,
3550                                (int)PERL_SUBVERSION, ARCHNAME);
3551                 if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
3552                       S_ISDIR(tmpstatbuf.st_mode))
3553                     av_push(GvAVn(PL_incgv), newSVsv(subdir));
3554
3555                 /* .../version if -d .../version */
3556                 Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_AV_SUFFIX_FMT PERL_FS_VER_FMT, libdir,
3557                                (int)PERL_REVISION, (int)PERL_VERSION,
3558                                (int)PERL_SUBVERSION);
3559                 if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
3560                       S_ISDIR(tmpstatbuf.st_mode))
3561                     av_push(GvAVn(PL_incgv), newSVsv(subdir));
3562
3563                 /* .../archname if -d .../archname */
3564                 Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_ARCH_FMT, libdir, ARCHNAME);
3565                 if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
3566                       S_ISDIR(tmpstatbuf.st_mode))
3567                     av_push(GvAVn(PL_incgv), newSVsv(subdir));
3568             }
3569
3570 #ifdef PERL_INC_VERSION_LIST
3571             if (addoldvers) {
3572                 for (incver = incverlist; *incver; incver++) {
3573                     /* .../xxx if -d .../xxx */
3574                     Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_ARCH_FMT, libdir, *incver);
3575                     if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
3576                           S_ISDIR(tmpstatbuf.st_mode))
3577                         av_push(GvAVn(PL_incgv), newSVsv(subdir));
3578                 }
3579             }
3580 #endif
3581         }
3582
3583         /* finally push this lib directory on the end of @INC */
3584         av_push(GvAVn(PL_incgv), libdir);
3585     }
3586 }
3587
3588 #ifdef USE_THREADS
3589 STATIC struct perl_thread *
3590 S_init_main_thread(pTHX)
3591 {
3592 #if !defined(PERL_IMPLICIT_CONTEXT)
3593     struct perl_thread *thr;
3594 #endif
3595     XPV *xpv;
3596
3597     Newz(53, thr, 1, struct perl_thread);
3598     PL_curcop = &PL_compiling;
3599     thr->interp = PERL_GET_INTERP;
3600     thr->cvcache = newHV();
3601     thr->threadsv = newAV();
3602     /* thr->threadsvp is set when find_threadsv is called */
3603     thr->specific = newAV();
3604     thr->flags = THRf_R_JOINABLE;
3605     MUTEX_INIT(&thr->mutex);
3606     /* Handcraft thrsv similarly to mess_sv */
3607     New(53, PL_thrsv, 1, SV);
3608     Newz(53, xpv, 1, XPV);
3609     SvFLAGS(PL_thrsv) = SVt_PV;
3610     SvANY(PL_thrsv) = (void*)xpv;
3611     SvREFCNT(PL_thrsv) = 1 << 30;       /* practically infinite */
3612     SvPVX(PL_thrsv) = (char*)thr;
3613     SvCUR_set(PL_thrsv, sizeof(thr));
3614     SvLEN_set(PL_thrsv, sizeof(thr));
3615     *SvEND(PL_thrsv) = '\0';    /* in the trailing_nul field */
3616     thr->oursv = PL_thrsv;
3617     PL_chopset = " \n-";
3618     PL_dumpindent = 4;
3619
3620     MUTEX_LOCK(&PL_threads_mutex);
3621     PL_nthreads++;
3622     thr->tid = 0;
3623     thr->next = thr;
3624     thr->prev = thr;
3625     MUTEX_UNLOCK(&PL_threads_mutex);
3626
3627 #ifdef HAVE_THREAD_INTERN
3628     Perl_init_thread_intern(thr);
3629 #endif
3630
3631 #ifdef SET_THREAD_SELF
3632     SET_THREAD_SELF(thr);
3633 #else
3634     thr->self = pthread_self();
3635 #endif /* SET_THREAD_SELF */
3636     PERL_SET_THX(thr);
3637
3638     /*
3639      * These must come after the SET_THR because sv_setpvn does
3640      * SvTAINT and the taint fields require dTHR.
3641      */
3642     PL_toptarget = NEWSV(0,0);
3643     sv_upgrade(PL_toptarget, SVt_PVFM);
3644     sv_setpvn(PL_toptarget, "", 0);
3645     PL_bodytarget = NEWSV(0,0);
3646     sv_upgrade(PL_bodytarget, SVt_PVFM);
3647     sv_setpvn(PL_bodytarget, "", 0);
3648     PL_formtarget = PL_bodytarget;
3649     thr->errsv = newSVpvn("", 0);
3650     (void) find_threadsv("@");  /* Ensure $@ is initialised early */
3651
3652     PL_maxscream = -1;
3653     PL_regcompp = MEMBER_TO_FPTR(Perl_pregcomp);
3654     PL_regexecp = MEMBER_TO_FPTR(Perl_regexec_flags);
3655     PL_regint_start = MEMBER_TO_FPTR(Perl_re_intuit_start);
3656     PL_regint_string = MEMBER_TO_FPTR(Perl_re_intuit_string);
3657     PL_regfree = MEMBER_TO_FPTR(Perl_pregfree);
3658     PL_regindent = 0;
3659     PL_reginterp_cnt = 0;
3660
3661     return thr;
3662 }
3663 #endif /* USE_THREADS */
3664
3665 void
3666 Perl_call_list(pTHX_ I32 oldscope, AV *paramList)
3667 {
3668     dTHR;
3669     SV *atsv;
3670     line_t oldline = CopLINE(PL_curcop);
3671     CV *cv;
3672     STRLEN len;
3673     int ret;
3674     dJMPENV;
3675
3676     while (AvFILL(paramList) >= 0) {
3677         cv = (CV*)av_shift(paramList);
3678         SAVEFREESV(cv);
3679 #ifdef PERL_FLEXIBLE_EXCEPTIONS
3680         CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_vcall_list_body), cv);
3681 #else
3682         JMPENV_PUSH(ret);
3683 #endif
3684         switch (ret) {
3685         case 0:
3686 #ifndef PERL_FLEXIBLE_EXCEPTIONS
3687             call_list_body(cv);
3688 #endif
3689             atsv = ERRSV;
3690             (void)SvPV(atsv, len);
3691             if (len) {
3692                 STRLEN n_a;
3693                 PL_curcop = &PL_compiling;
3694                 CopLINE_set(PL_curcop, oldline);
3695                 if (paramList == PL_beginav)
3696                     sv_catpv(atsv, "BEGIN failed--compilation aborted");
3697                 else
3698                     Perl_sv_catpvf(aTHX_ atsv,
3699                                    "%s failed--call queue aborted",
3700                                    paramList == PL_checkav ? "CHECK"
3701                                    : paramList == PL_initav ? "INIT"
3702                                    : "END");
3703                 while (PL_scopestack_ix > oldscope)
3704                     LEAVE;
3705                 JMPENV_POP;
3706                 Perl_croak(aTHX_ "%s", SvPVx(atsv, n_a));
3707             }
3708             break;
3709         case 1:
3710             STATUS_ALL_FAILURE;
3711             /* FALL THROUGH */
3712         case 2:
3713             /* my_exit() was called */
3714             while (PL_scopestack_ix > oldscope)
3715                 LEAVE;
3716             FREETMPS;
3717             PL_curstash = PL_defstash;
3718             PL_curcop = &PL_compiling;
3719             CopLINE_set(PL_curcop, oldline);
3720             JMPENV_POP;
3721             if (PL_statusvalue && !(PL_exit_flags & PERL_EXIT_EXPECTED)) {
3722                 if (paramList == PL_beginav)
3723                     Perl_croak(aTHX_ "BEGIN failed--compilation aborted");
3724                 else
3725                     Perl_croak(aTHX_ "%s failed--call queue aborted",
3726                                paramList == PL_checkav ? "CHECK"
3727                                : paramList == PL_initav ? "INIT"
3728                                : "END");
3729             }
3730             my_exit_jump();
3731             /* NOTREACHED */
3732         case 3:
3733             if (PL_restartop) {
3734                 PL_curcop = &PL_compiling;
3735                 CopLINE_set(PL_curcop, oldline);
3736                 JMPENV_JUMP(3);
3737             }
3738             PerlIO_printf(Perl_error_log, "panic: restartop\n");
3739             FREETMPS;
3740             break;
3741         }
3742         JMPENV_POP;
3743     }
3744 }
3745
3746 #ifdef PERL_FLEXIBLE_EXCEPTIONS
3747 STATIC void *
3748 S_vcall_list_body(pTHX_ va_list args)
3749 {
3750     CV *cv = va_arg(args, CV*);
3751     return call_list_body(cv);
3752 }
3753 #endif
3754
3755 STATIC void *
3756 S_call_list_body(pTHX_ CV *cv)
3757 {
3758     PUSHMARK(PL_stack_sp);
3759     call_sv((SV*)cv, G_EVAL|G_DISCARD);
3760     return NULL;
3761 }
3762
3763 void
3764 Perl_my_exit(pTHX_ U32 status)
3765 {
3766     dTHR;
3767
3768     DEBUG_S(PerlIO_printf(Perl_debug_log, "my_exit: thread %p, status %lu\n",
3769                           thr, (unsigned long) status));
3770     switch (status) {
3771     case 0:
3772         STATUS_ALL_SUCCESS;
3773         break;
3774     case 1:
3775         STATUS_ALL_FAILURE;
3776         break;
3777     default:
3778         STATUS_NATIVE_SET(status);
3779         break;
3780     }
3781     my_exit_jump();
3782 }
3783
3784 void
3785 Perl_my_failure_exit(pTHX)
3786 {
3787 #ifdef VMS
3788     if (vaxc$errno & 1) {
3789         if (STATUS_NATIVE & 1)          /* fortuitiously includes "-1" */
3790             STATUS_NATIVE_SET(44);
3791     }
3792     else {
3793         if (!vaxc$errno && errno)       /* unlikely */
3794             STATUS_NATIVE_SET(44);
3795         else
3796             STATUS_NATIVE_SET(vaxc$errno);
3797     }
3798 #else
3799     int exitstatus;
3800     if (errno & 255)
3801         STATUS_POSIX_SET(errno);
3802     else {
3803         exitstatus = STATUS_POSIX >> 8;
3804         if (exitstatus & 255)
3805             STATUS_POSIX_SET(exitstatus);
3806         else
3807             STATUS_POSIX_SET(255);
3808     }
3809 #endif
3810     my_exit_jump();
3811 }
3812
3813 STATIC void
3814 S_my_exit_jump(pTHX)
3815 {
3816     dTHR;
3817     register PERL_CONTEXT *cx;
3818     I32 gimme;
3819     SV **newsp;
3820
3821     if (PL_e_script) {
3822         SvREFCNT_dec(PL_e_script);
3823         PL_e_script = Nullsv;
3824     }
3825
3826     POPSTACK_TO(PL_mainstack);
3827     if (cxstack_ix >= 0) {
3828         if (cxstack_ix > 0)
3829             dounwind(0);
3830         POPBLOCK(cx,PL_curpm);
3831         LEAVE;
3832     }
3833
3834     JMPENV_JUMP(2);
3835 }
3836
3837 #ifdef PERL_OBJECT
3838 #include "XSUB.h"
3839 #endif
3840
3841 static I32
3842 read_e_script(pTHXo_ int idx, SV *buf_sv, int maxlen)
3843 {
3844     char *p, *nl;
3845     p  = SvPVX(PL_e_script);
3846     nl = strchr(p, '\n');
3847     nl = (nl) ? nl+1 : SvEND(PL_e_script);
3848     if (nl-p == 0) {
3849         filter_del(read_e_script);
3850         return 0;
3851     }
3852     sv_catpvn(buf_sv, p, nl-p);
3853     sv_chop(PL_e_script, nl);
3854     return 1;
3855 }