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