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