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