perl.c

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