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