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