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 = (PerlInterpreter*)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     PerlMem_free(this);
 564 #else
 565     PerlMem_free(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     boot_core_xsutils();
 930
 931     if (xsinit)
 932         (*xsinit)(aTHXo);       /* in case linked C routines want magical variables */
 933 #if defined(VMS) || defined(WIN32) || defined(DJGPP)
 934     init_os_extras();
 935 #endif
 936
 937 #ifdef USE_SOCKS
 938     SOCKSinit(argv[0]);
 939 #endif
 940
 941     init_predump_symbols();
 942     /* init_postdump_symbols not currently designed to be called */
 943     /* more than once (ENV isn't cleared first, for example)     */
 944     /* But running with -u leaves %ENV & @ARGV undefined!    XXX */
 945     if (!PL_do_undump)
 946         init_postdump_symbols(argc,argv,env);
 947
 948     init_lexer();
 949
 950     /* now parse the script */
 951
 952     SETERRNO(0,SS$_NORMAL);
 953     PL_error_count = 0;
 954     if (yyparse() || PL_error_count) {
 955         if (PL_minus_c)
 956             Perl_croak(aTHX_ "%s had compilation errors.\n", PL_origfilename);
 957         else {
 958             Perl_croak(aTHX_ "Execution of %s aborted due to compilation errors.\n",
 959                        PL_origfilename);
 960         }
 961     }
 962     PL_curcop->cop_line = 0;
 963     PL_curstash = PL_defstash;
 964     PL_preprocess = FALSE;
 965     if (PL_e_script) {
 966         SvREFCNT_dec(PL_e_script);
 967         PL_e_script = Nullsv;
 968     }
 969
 970     /* now that script is parsed, we can modify record separator */
 971     SvREFCNT_dec(PL_rs);
 972     PL_rs = SvREFCNT_inc(PL_nrs);
 973     sv_setsv(get_sv("/", TRUE), PL_rs);
 974     if (PL_do_undump)
 975         my_unexec();
 976
 977     if (isWARN_ONCE)
 978         gv_check(PL_defstash);
 979
 980     LEAVE;
 981     FREETMPS;
 982
 983 #ifdef MYMALLOC
 984     if ((s=PerlEnv_getenv("PERL_DEBUG_MSTATS")) && atoi(s) >= 2)
 985         dump_mstats("after compilation:");
 986 #endif
 987
 988     ENTER;
 989     PL_restartop = 0;
 990     return NULL;
 991 }
 992
 993 int
 994 perl_run(pTHXx)
 995 {
 996     dTHR;
 997     I32 oldscope;
 998     int ret;
 999 #ifdef USE_THREADS
1000     dTHX;
1001 #endif
1002
1003     oldscope = PL_scopestack_ix;
1004
1005  redo_body:
1006     CALLPROTECT(aTHX_ &ret, MEMBER_TO_FPTR(S_run_body), oldscope);
1007     switch (ret) {
1008     case 1:
1009         cxstack_ix = -1;                /* start context stack again */
1010         goto redo_body;
1011     case 0:  /* normal completion */
1012     case 2:  /* my_exit() */
1013         while (PL_scopestack_ix > oldscope)
1014             LEAVE;
1015         FREETMPS;
1016         PL_curstash = PL_defstash;
1017         if (PL_endav)
1018             call_list(oldscope, PL_endav);
1019 #ifdef MYMALLOC
1020         if (PerlEnv_getenv("PERL_DEBUG_MSTATS"))
1021             dump_mstats("after execution:  ");
1022 #endif
1023         return STATUS_NATIVE_EXPORT;
1024     case 3:
1025         if (PL_restartop) {
1026             POPSTACK_TO(PL_mainstack);
1027             goto redo_body;
1028         }
1029         PerlIO_printf(PerlIO_stderr(), "panic: restartop\n");
1030         FREETMPS;
1031         return 1;
1032     }
1033
1034     /* NOTREACHED */
1035     return 0;
1036 }
1037
1038 STATIC void *
1039 S_run_body(pTHX_ va_list args)
1040 {
1041     dTHR;
1042     I32 oldscope = va_arg(args, I32);
1043
1044     DEBUG_r(PerlIO_printf(Perl_debug_log, "%s $` $& $' support.\n",
1045                     PL_sawampersand ? "Enabling" : "Omitting"));
1046
1047     if (!PL_restartop) {
1048         DEBUG_x(dump_all());
1049         DEBUG(PerlIO_printf(Perl_debug_log, "\nEXECUTING...\n\n"));
1050         DEBUG_S(PerlIO_printf(Perl_debug_log, "main thread is 0x%lx\n",
1051                               (unsigned long) thr));
1052
1053         if (PL_minus_c) {
1054             PerlIO_printf(PerlIO_stderr(), "%s syntax OK\n", PL_origfilename);
1055             my_exit(0);
1056         }
1057         if (PERLDB_SINGLE && PL_DBsingle)
1058             sv_setiv(PL_DBsingle, 1);
1059         if (PL_initav)
1060             call_list(oldscope, PL_initav);
1061     }
1062
1063     /* do it */
1064
1065     if (PL_restartop) {
1066         PL_op = PL_restartop;
1067         PL_restartop = 0;
1068         CALLRUNOPS(aTHX);
1069     }
1070     else if (PL_main_start) {
1071         CvDEPTH(PL_main_cv) = 1;
1072         PL_op = PL_main_start;
1073         CALLRUNOPS(aTHX);
1074     }
1075
1076     my_exit(0);
1077     /* NOTREACHED */
1078     return NULL;
1079 }
1080
1081 SV*
1082 Perl_get_sv(pTHX_ const char *name, I32 create)
1083 {
1084     GV *gv;
1085 #ifdef USE_THREADS
1086     if (name[1] == '\0' && !isALPHA(name[0])) {
1087         PADOFFSET tmp = find_threadsv(name);
1088         if (tmp != NOT_IN_PAD) {
1089             dTHR;
1090             return THREADSV(tmp);
1091         }
1092     }
1093 #endif /* USE_THREADS */
1094     gv = gv_fetchpv(name, create, SVt_PV);
1095     if (gv)
1096         return GvSV(gv);
1097     return Nullsv;
1098 }
1099
1100 AV*
1101 Perl_get_av(pTHX_ const char *name, I32 create)
1102 {
1103     GV* gv = gv_fetchpv(name, create, SVt_PVAV);
1104     if (create)
1105         return GvAVn(gv);
1106     if (gv)
1107         return GvAV(gv);
1108     return Nullav;
1109 }
1110
1111 HV*
1112 Perl_get_hv(pTHX_ const char *name, I32 create)
1113 {
1114     GV* gv = gv_fetchpv(name, create, SVt_PVHV);
1115     if (create)
1116         return GvHVn(gv);
1117     if (gv)
1118         return GvHV(gv);
1119     return Nullhv;
1120 }
1121
1122 CV*
1123 Perl_get_cv(pTHX_ const char *name, I32 create)
1124 {
1125     GV* gv = gv_fetchpv(name, create, SVt_PVCV);
1126     /* XXX unsafe for threads if eval_owner isn't held */
1127     /* XXX this is probably not what they think they're getting.
1128      * It has the same effect as "sub name;", i.e. just a forward
1129      * declaration! */
1130     if (create && !GvCVu(gv))
1131         return newSUB(start_subparse(FALSE, 0),
1132                       newSVOP(OP_CONST, 0, newSVpv(name,0)),
1133                       Nullop,
1134                       Nullop);
1135     if (gv)
1136         return GvCVu(gv);
1137     return Nullcv;
1138 }
1139
1140 /* Be sure to refetch the stack pointer after calling these routines. */
1141
1142 I32
1143 Perl_call_argv(pTHX_ const char *sub_name, I32 flags, register char **argv)
1144
1145                         /* See G_* flags in cop.h */
1146                         /* null terminated arg list */
1147 {
1148     dSP;
1149
1150     PUSHMARK(SP);
1151     if (argv) {
1152         while (*argv) {
1153             XPUSHs(sv_2mortal(newSVpv(*argv,0)));
1154             argv++;
1155         }
1156         PUTBACK;
1157     }
1158     return call_pv(sub_name, flags);
1159 }
1160
1161 I32
1162 Perl_call_pv(pTHX_ const char *sub_name, I32 flags)
1163                         /* name of the subroutine */
1164                         /* See G_* flags in cop.h */
1165 {
1166     return call_sv((SV*)get_cv(sub_name, TRUE), flags);
1167 }
1168
1169 I32
1170 Perl_call_method(pTHX_ const char *methname, I32 flags)
1171                         /* name of the subroutine */
1172                         /* See G_* flags in cop.h */
1173 {
1174     dSP;
1175     OP myop;
1176     if (!PL_op)
1177         PL_op = &myop;
1178     XPUSHs(sv_2mortal(newSVpv(methname,0)));
1179     PUTBACK;
1180     pp_method();
1181         if(PL_op == &myop)
1182                 PL_op = Nullop;
1183     return call_sv(*PL_stack_sp--, flags);
1184 }
1185
1186 /* May be called with any of a CV, a GV, or an SV containing the name. */
1187 I32
1188 Perl_call_sv(pTHX_ SV *sv, I32 flags)
1189
1190                         /* See G_* flags in cop.h */
1191 {
1192     dSP;
1193     LOGOP myop;         /* fake syntax tree node */
1194     I32 oldmark;
1195     I32 retval;
1196     I32 oldscope;
1197     bool oldcatch = CATCH_GET;
1198     int ret;
1199     OP* oldop = PL_op;
1200
1201     if (flags & G_DISCARD) {
1202         ENTER;
1203         SAVETMPS;
1204     }
1205
1206     Zero(&myop, 1, LOGOP);
1207     myop.op_next = Nullop;
1208     if (!(flags & G_NOARGS))
1209         myop.op_flags |= OPf_STACKED;
1210     myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
1211                       (flags & G_ARRAY) ? OPf_WANT_LIST :
1212                       OPf_WANT_SCALAR);
1213     SAVEOP();
1214     PL_op = (OP*)&myop;
1215
1216     EXTEND(PL_stack_sp, 1);
1217     *++PL_stack_sp = sv;
1218     oldmark = TOPMARK;
1219     oldscope = PL_scopestack_ix;
1220
1221     if (PERLDB_SUB && PL_curstash != PL_debstash
1222            /* Handle first BEGIN of -d. */
1223           && (PL_DBcv || (PL_DBcv = GvCV(PL_DBsub)))
1224            /* Try harder, since this may have been a sighandler, thus
1225             * curstash may be meaningless. */
1226           && (SvTYPE(sv) != SVt_PVCV || CvSTASH((CV*)sv) != PL_debstash)
1227           && !(flags & G_NODEBUG))
1228         PL_op->op_private |= OPpENTERSUB_DB;
1229
1230     if (!(flags & G_EVAL)) {
1231         /* G_NOCATCH is a hack for perl_vdie using this path to call
1232            a __DIE__ handler */
1233         if (!(flags & G_NOCATCH)) {
1234             CATCH_SET(TRUE);
1235         }
1236         call_xbody((OP*)&myop, FALSE);
1237         retval = PL_stack_sp - (PL_stack_base + oldmark);
1238         if (!(flags & G_NOCATCH)) {
1239             CATCH_SET(FALSE);
1240         }
1241     }
1242     else {
1243         cLOGOP->op_other = PL_op;
1244         PL_markstack_ptr--;
1245         /* we're trying to emulate pp_entertry() here */
1246         {
1247             register PERL_CONTEXT *cx;
1248             I32 gimme = GIMME_V;
1249
1250             ENTER;
1251             SAVETMPS;
1252
1253             push_return(PL_op->op_next);
1254             PUSHBLOCK(cx, CXt_EVAL, PL_stack_sp);
1255             PUSHEVAL(cx, 0, 0);
1256             PL_eval_root = PL_op;             /* Only needed so that goto works right. */
1257
1258             PL_in_eval = EVAL_INEVAL;
1259             if (flags & G_KEEPERR)
1260                 PL_in_eval |= EVAL_KEEPERR;
1261             else
1262                 sv_setpv(ERRSV,"");
1263         }
1264         PL_markstack_ptr++;
1265
1266   redo_body:
1267         CALLPROTECT(aTHX_ &ret, MEMBER_TO_FPTR(S_call_body), (OP*)&myop, FALSE);
1268         switch (ret) {
1269         case 0:
1270             retval = PL_stack_sp - (PL_stack_base + oldmark);
1271             if (!(flags & G_KEEPERR))
1272                 sv_setpv(ERRSV,"");
1273             break;
1274         case 1:
1275             STATUS_ALL_FAILURE;
1276             /* FALL THROUGH */
1277         case 2:
1278             /* my_exit() was called */
1279             PL_curstash = PL_defstash;
1280             FREETMPS;
1281             if (PL_statusvalue)
1282                 Perl_croak(aTHX_ "Callback called exit");
1283             my_exit_jump();
1284             /* NOTREACHED */
1285         case 3:
1286             if (PL_restartop) {
1287                 PL_op = PL_restartop;
1288                 PL_restartop = 0;
1289                 goto redo_body;
1290             }
1291             PL_stack_sp = PL_stack_base + oldmark;
1292             if (flags & G_ARRAY)
1293                 retval = 0;
1294             else {
1295                 retval = 1;
1296                 *++PL_stack_sp = &PL_sv_undef;
1297             }
1298             break;
1299         }
1300
1301         if (PL_scopestack_ix > oldscope) {
1302             SV **newsp;
1303             PMOP *newpm;
1304             I32 gimme;
1305             register PERL_CONTEXT *cx;
1306             I32 optype;
1307
1308             POPBLOCK(cx,newpm);
1309             POPEVAL(cx);
1310             pop_return();
1311             PL_curpm = newpm;
1312             LEAVE;
1313         }
1314     }
1315
1316     if (flags & G_DISCARD) {
1317         PL_stack_sp = PL_stack_base + oldmark;
1318         retval = 0;
1319         FREETMPS;
1320         LEAVE;
1321     }
1322     PL_op = oldop;
1323     return retval;
1324 }
1325
1326 STATIC void *
1327 S_call_body(pTHX_ va_list args)
1328 {
1329     OP *myop = va_arg(args, OP*);
1330     int is_eval = va_arg(args, int);
1331
1332     call_xbody(myop, is_eval);
1333     return NULL;
1334 }
1335
1336 STATIC void
1337 S_call_xbody(pTHX_ OP *myop, int is_eval)
1338 {
1339     dTHR;
1340
1341     if (PL_op == myop) {
1342         if (is_eval)
1343             PL_op = Perl_pp_entereval(aTHX);
1344         else
1345             PL_op = Perl_pp_entersub(aTHX);
1346     }
1347     if (PL_op)
1348         CALLRUNOPS(aTHX);
1349 }
1350
1351 /* Eval a string. The G_EVAL flag is always assumed. */
1352
1353 I32
1354 Perl_eval_sv(pTHX_ SV *sv, I32 flags)
1355
1356                         /* See G_* flags in cop.h */
1357 {
1358     dSP;
1359     UNOP myop;          /* fake syntax tree node */
1360     I32 oldmark = SP - PL_stack_base;
1361     I32 retval;
1362     I32 oldscope;
1363     int ret;
1364     OP* oldop = PL_op;
1365
1366     if (flags & G_DISCARD) {
1367         ENTER;
1368         SAVETMPS;
1369     }
1370
1371     SAVEOP();
1372     PL_op = (OP*)&myop;
1373     Zero(PL_op, 1, UNOP);
1374     EXTEND(PL_stack_sp, 1);
1375     *++PL_stack_sp = sv;
1376     oldscope = PL_scopestack_ix;
1377
1378     if (!(flags & G_NOARGS))
1379         myop.op_flags = OPf_STACKED;
1380     myop.op_next = Nullop;
1381     myop.op_type = OP_ENTEREVAL;
1382     myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
1383                       (flags & G_ARRAY) ? OPf_WANT_LIST :
1384                       OPf_WANT_SCALAR);
1385     if (flags & G_KEEPERR)
1386         myop.op_flags |= OPf_SPECIAL;
1387
1388  redo_body:
1389     CALLPROTECT(aTHX_ &ret, MEMBER_TO_FPTR(S_call_body), (OP*)&myop, TRUE);
1390     switch (ret) {
1391     case 0:
1392         retval = PL_stack_sp - (PL_stack_base + oldmark);
1393         if (!(flags & G_KEEPERR))
1394             sv_setpv(ERRSV,"");
1395         break;
1396     case 1:
1397         STATUS_ALL_FAILURE;
1398         /* FALL THROUGH */
1399     case 2:
1400         /* my_exit() was called */
1401         PL_curstash = PL_defstash;
1402         FREETMPS;
1403         if (PL_statusvalue)
1404             Perl_croak(aTHX_ "Callback called exit");
1405         my_exit_jump();
1406         /* NOTREACHED */
1407     case 3:
1408         if (PL_restartop) {
1409             PL_op = PL_restartop;
1410             PL_restartop = 0;
1411             goto redo_body;
1412         }
1413         PL_stack_sp = PL_stack_base + oldmark;
1414         if (flags & G_ARRAY)
1415             retval = 0;
1416         else {
1417             retval = 1;
1418             *++PL_stack_sp = &PL_sv_undef;
1419         }
1420         break;
1421     }
1422
1423     if (flags & G_DISCARD) {
1424         PL_stack_sp = PL_stack_base + oldmark;
1425         retval = 0;
1426         FREETMPS;
1427         LEAVE;
1428     }
1429     PL_op = oldop;
1430     return retval;
1431 }
1432
1433 SV*
1434 Perl_eval_pv(pTHX_ const char *p, I32 croak_on_error)
1435 {
1436     dSP;
1437     SV* sv = newSVpv(p, 0);
1438
1439     PUSHMARK(SP);
1440     eval_sv(sv, G_SCALAR);
1441     SvREFCNT_dec(sv);
1442
1443     SPAGAIN;
1444     sv = POPs;
1445     PUTBACK;
1446
1447     if (croak_on_error && SvTRUE(ERRSV)) {
1448         STRLEN n_a;
1449         Perl_croak(aTHX_ SvPVx(ERRSV, n_a));
1450     }
1451
1452     return sv;
1453 }
1454
1455 /* Require a module. */
1456
1457 void
1458 Perl_require_pv(pTHX_ const char *pv)
1459 {
1460     SV* sv;
1461     dSP;
1462     PUSHSTACKi(PERLSI_REQUIRE);
1463     PUTBACK;
1464     sv = sv_newmortal();
1465     sv_setpv(sv, "require '");
1466     sv_catpv(sv, pv);
1467     sv_catpv(sv, "'");
1468     eval_sv(sv, G_DISCARD);
1469     SPAGAIN;
1470     POPSTACK;
1471 }
1472
1473 void
1474 Perl_magicname(pTHX_ char *sym, char *name, I32 namlen)
1475 {
1476     register GV *gv;
1477
1478     if (gv = gv_fetchpv(sym,TRUE, SVt_PV))
1479         sv_magic(GvSV(gv), (SV*)gv, 0, name, namlen);
1480 }
1481
1482 STATIC void
1483 S_usage(pTHX_ char *name)               /* XXX move this out into a module ? */
1484 {
1485     /* This message really ought to be max 23 lines.
1486      * Removed -h because the user already knows that opton. Others? */
1487
1488     static char *usage_msg[] = {
1489 "-0[octal]       specify record separator (\\0, if no argument)",
1490 "-a              autosplit mode with -n or -p (splits $_ into @F)",
1491 "-c              check syntax only (runs BEGIN and END blocks)",
1492 "-d[:debugger]   run program under debugger",
1493 "-D[number/list] set debugging flags (argument is a bit mask or alphabets)",
1494 "-e 'command'    one line of program (several -e's allowed, omit programfile)",
1495 "-F/pattern/     split() pattern for -a switch (//'s are optional)",
1496 "-i[extension]   edit <> files in place (makes backup if extension supplied)",
1497 "-Idirectory     specify @INC/#include directory (several -I's allowed)",
1498 "-l[octal]       enable line ending processing, specifies line terminator",
1499 "-[mM][-]module  execute `use/no module...' before executing program",
1500 "-n              assume 'while (<>) { ... }' loop around program",
1501 "-p              assume loop like -n but print line also, like sed",
1502 "-P              run program through C preprocessor before compilation",
1503 "-s              enable rudimentary parsing for switches after programfile",
1504 "-S              look for programfile using PATH environment variable",
1505 "-T              enable tainting checks",
1506 "-u              dump core after parsing program",
1507 "-U              allow unsafe operations",
1508 "-v              print version, subversion (includes VERY IMPORTANT perl info)",
1509 "-V[:variable]   print configuration summary (or a single Config.pm variable)",
1510 "-w              enable many useful warnings (RECOMMENDED)",
1511 "-x[directory]   strip off text before #!perl line and perhaps cd to directory",
1512 "\n",
1513 NULL
1514 };
1515     char **p = usage_msg;
1516
1517     printf("\nUsage: %s [switches] [--] [programfile] [arguments]", name);
1518     while (*p)
1519         printf("\n  %s", *p++);
1520 }
1521
1522 /* This routine handles any switches that can be given during run */
1523
1524 char *
1525 Perl_moreswitches(pTHX_ char *s)
1526 {
1527     I32 numlen;
1528     U32 rschar;
1529
1530     switch (*s) {
1531     case '0':
1532     {
1533         dTHR;
1534         rschar = scan_oct(s, 4, &numlen);
1535         SvREFCNT_dec(PL_nrs);
1536         if (rschar & ~((U8)~0))
1537             PL_nrs = &PL_sv_undef;
1538         else if (!rschar && numlen >= 2)
1539             PL_nrs = newSVpvn("", 0);
1540         else {
1541             char ch = rschar;
1542             PL_nrs = newSVpvn(&ch, 1);
1543         }
1544         return s + numlen;
1545     }
1546     case 'F':
1547         PL_minus_F = TRUE;
1548         PL_splitstr = savepv(s + 1);
1549         s += strlen(s);
1550         return s;
1551     case 'a':
1552         PL_minus_a = TRUE;
1553         s++;
1554         return s;
1555     case 'c':
1556         PL_minus_c = TRUE;
1557         s++;
1558         return s;
1559     case 'd':
1560         forbid_setid("-d");
1561         s++;
1562         if (*s == ':' || *s == '=')  {
1563             my_setenv("PERL5DB", Perl_form(aTHX_ "use Devel::%s;", ++s));
1564             s += strlen(s);
1565         }
1566         if (!PL_perldb) {
1567             PL_perldb = PERLDB_ALL;
1568             init_debugger();
1569         }
1570         return s;
1571     case 'D':
1572     {
1573 #ifdef DEBUGGING
1574         forbid_setid("-D");
1575         if (isALPHA(s[1])) {
1576             static char debopts[] = "psltocPmfrxuLHXDS";
1577             char *d;
1578
1579             for (s++; *s && (d = strchr(debopts,*s)); s++)
1580                 PL_debug |= 1 << (d - debopts);
1581         }
1582         else {
1583             PL_debug = atoi(s+1);
1584             for (s++; isDIGIT(*s); s++) ;
1585         }
1586         PL_debug |= 0x80000000;
1587 #else
1588         dTHR;
1589         if (ckWARN_d(WARN_DEBUGGING))
1590             Perl_warner(aTHX_ WARN_DEBUGGING,
1591                    "Recompile perl with -DDEBUGGING to use -D switch\n");
1592         for (s++; isALNUM(*s); s++) ;
1593 #endif
1594         /*SUPPRESS 530*/
1595         return s;
1596     }
1597     case 'h':
1598         usage(PL_origargv[0]);
1599         PerlProc_exit(0);
1600     case 'i':
1601         if (PL_inplace)
1602             Safefree(PL_inplace);
1603         PL_inplace = savepv(s+1);
1604         /*SUPPRESS 530*/
1605         for (s = PL_inplace; *s && !isSPACE(*s); s++) ;
1606         if (*s) {
1607             *s++ = '\0';
1608             if (*s == '-')      /* Additional switches on #! line. */
1609                 s++;
1610         }
1611         return s;
1612     case 'I':   /* -I handled both here and in parse_perl() */
1613         forbid_setid("-I");
1614         ++s;
1615         while (*s && isSPACE(*s))
1616             ++s;
1617         if (*s) {
1618             char *e, *p;
1619             for (e = s; *e && !isSPACE(*e); e++) ;
1620             p = savepvn(s, e-s);
1621             incpush(p, TRUE);
1622             Safefree(p);
1623             s = e;
1624         }
1625         else
1626             Perl_croak(aTHX_ "No space allowed after -I");
1627         return s;
1628     case 'l':
1629         PL_minus_l = TRUE;
1630         s++;
1631         if (PL_ors)
1632             Safefree(PL_ors);
1633         if (isDIGIT(*s)) {
1634             PL_ors = savepv("\n");
1635             PL_orslen = 1;
1636             *PL_ors = scan_oct(s, 3 + (*s == '0'), &numlen);
1637             s += numlen;
1638         }
1639         else {
1640             dTHR;
1641             if (RsPARA(PL_nrs)) {
1642                 PL_ors = "\n\n";
1643                 PL_orslen = 2;
1644             }
1645             else
1646                 PL_ors = SvPV(PL_nrs, PL_orslen);
1647             PL_ors = savepvn(PL_ors, PL_orslen);
1648         }
1649         return s;
1650     case 'M':
1651         forbid_setid("-M");     /* XXX ? */
1652         /* FALL THROUGH */
1653     case 'm':
1654         forbid_setid("-m");     /* XXX ? */
1655         if (*++s) {
1656             char *start;
1657             SV *sv;
1658             char *use = "use ";
1659             /* -M-foo == 'no foo'       */
1660             if (*s == '-') { use = "no "; ++s; }
1661             sv = newSVpv(use,0);
1662             start = s;
1663             /* We allow -M'Module qw(Foo Bar)'  */
1664             while(isALNUM(*s) || *s==':') ++s;
1665             if (*s != '=') {
1666                 sv_catpv(sv, start);
1667                 if (*(start-1) == 'm') {
1668                     if (*s != '\0')
1669                         Perl_croak(aTHX_ "Can't use '%c' after -mname", *s);
1670                     sv_catpv( sv, " ()");
1671                 }
1672             } else {
1673                 sv_catpvn(sv, start, s-start);
1674                 sv_catpv(sv, " split(/,/,q{");
1675                 sv_catpv(sv, ++s);
1676                 sv_catpv(sv,    "})");
1677             }
1678             s += strlen(s);
1679             if (PL_preambleav == NULL)
1680                 PL_preambleav = newAV();
1681             av_push(PL_preambleav, sv);
1682         }
1683         else
1684             Perl_croak(aTHX_ "No space allowed after -%c", *(s-1));
1685         return s;
1686     case 'n':
1687         PL_minus_n = TRUE;
1688         s++;
1689         return s;
1690     case 'p':
1691         PL_minus_p = TRUE;
1692         s++;
1693         return s;
1694     case 's':
1695         forbid_setid("-s");
1696         PL_doswitches = TRUE;
1697         s++;
1698         return s;
1699     case 'T':
1700         if (!PL_tainting)
1701             Perl_croak(aTHX_ "Too late for \"-T\" option");
1702         s++;
1703         return s;
1704     case 'u':
1705         PL_do_undump = TRUE;
1706         s++;
1707         return s;
1708     case 'U':
1709         PL_unsafe = TRUE;
1710         s++;
1711         return s;
1712     case 'v':
1713 #if defined(PERL_SUBVERSION) && PERL_SUBVERSION > 0
1714         printf("\nThis is perl, version %d.%03d_%02d built for %s",
1715             PERL_REVISION, PERL_VERSION, PERL_SUBVERSION, ARCHNAME);
1716 #else
1717         printf("\nThis is perl, version %s built for %s",
1718                 PL_patchlevel, ARCHNAME);
1719 #endif
1720 #if defined(LOCAL_PATCH_COUNT)
1721         if (LOCAL_PATCH_COUNT > 0)
1722             printf("\n(with %d registered patch%s, see perl -V for more detail)",
1723                 LOCAL_PATCH_COUNT, (LOCAL_PATCH_COUNT!=1) ? "es" : "");
1724 #endif
1725
1726         printf("\n\nCopyright 1987-1999, Larry Wall\n");
1727 #ifdef MSDOS
1728         printf("\nMS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n");
1729 #endif
1730 #ifdef DJGPP
1731         printf("djgpp v2 port (jpl5003c) by Hirofumi Watanabe, 1996\n");
1732         printf("djgpp v2 port (perl5004+) by Laszlo Molnar, 1997-1999\n");
1733 #endif
1734 #ifdef OS2
1735         printf("\n\nOS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n"
1736             "Version 5 port Copyright (c) 1994-1999, Andreas Kaiser, Ilya Zakharevich\n");
1737 #endif
1738 #ifdef atarist
1739         printf("atariST series port, ++jrb  bammi@cadence.com\n");
1740 #endif
1741 #ifdef __BEOS__
1742         printf("BeOS port Copyright Tom Spindler, 1997-1999\n");
1743 #endif
1744 #ifdef MPE
1745         printf("MPE/iX port Copyright by Mark Klein and Mark Bixby, 1996-1999\n");
1746 #endif
1747 #ifdef OEMVS
1748         printf("MVS (OS390) port by Mortice Kern Systems, 1997-1999\n");
1749 #endif
1750 #ifdef __VOS__
1751         printf("Stratus VOS port by Paul_Green@stratus.com, 1997-1999\n");
1752 #endif
1753 #ifdef __OPEN_VM
1754         printf("VM/ESA port by Neale Ferguson, 1998-1999\n");
1755 #endif
1756 #ifdef POSIX_BC
1757         printf("BS2000 (POSIX) port by Start Amadeus GmbH, 1998-1999\n");
1758 #endif
1759 #ifdef __MINT__
1760         printf("MiNT port by Guido Flohr, 1997-1999\n");
1761 #endif
1762 #ifdef BINARY_BUILD_NOTICE
1763         BINARY_BUILD_NOTICE;
1764 #endif
1765         printf("\n\
1766 Perl may be copied only under the terms of either the Artistic License or the\n\
1767 GNU General Public License, which may be found in the Perl 5.0 source kit.\n\n\
1768 Complete documentation for Perl, including FAQ lists, should be found on\n\
1769 this system using `man perl' or `perldoc perl'.  If you have access to the\n\
1770 Internet, point your browser at http://www.perl.com/, the Perl Home Page.\n\n");
1771         PerlProc_exit(0);
1772     case 'w':
1773         if (! (PL_dowarn & G_WARN_ALL_MASK))
1774             PL_dowarn |= G_WARN_ON;
1775         s++;
1776         return s;
1777     case 'W':
1778         PL_dowarn = G_WARN_ALL_ON|G_WARN_ON;
1779         PL_compiling.cop_warnings = WARN_ALL ;
1780         s++;
1781         return s;
1782     case 'X':
1783         PL_dowarn = G_WARN_ALL_OFF;
1784         PL_compiling.cop_warnings = WARN_NONE ;
1785         s++;
1786         return s;
1787     case '*':
1788     case ' ':
1789         if (s[1] == '-')        /* Additional switches on #! line. */
1790             return s+2;
1791         break;
1792     case '-':
1793     case 0:
1794 #if defined(WIN32) || !defined(PERL_STRICT_CR)
1795     case '\r':
1796 #endif
1797     case '\n':
1798     case '\t':
1799         break;
1800 #ifdef ALTERNATE_SHEBANG
1801     case 'S':                   /* OS/2 needs -S on "extproc" line. */
1802         break;
1803 #endif
1804     case 'P':
1805         if (PL_preprocess)
1806             return s+1;
1807         /* FALL THROUGH */
1808     default:
1809         Perl_croak(aTHX_ "Can't emulate -%.1s on #! line",s);
1810     }
1811     return Nullch;
1812 }
1813
1814 /* compliments of Tom Christiansen */
1815
1816 /* unexec() can be found in the Gnu emacs distribution */
1817 /* Known to work with -DUNEXEC and using unexelf.c from GNU emacs-20.2 */
1818
1819 void
1820 Perl_my_unexec(pTHX)
1821 {
1822 #ifdef UNEXEC
1823     SV*    prog;
1824     SV*    file;
1825     int    status = 1;
1826     extern int etext;
1827
1828     prog = newSVpv(BIN_EXP, 0);
1829     sv_catpv(prog, "/perl");
1830     file = newSVpv(PL_origfilename, 0);
1831     sv_catpv(file, ".perldump");
1832
1833     unexec(SvPVX(file), SvPVX(prog), &etext, sbrk(0), 0);
1834     /* unexec prints msg to stderr in case of failure */
1835     PerlProc_exit(status);
1836 #else
1837 #  ifdef VMS
1838 #    include <lib$routines.h>
1839      lib$signal(SS$_DEBUG);  /* ssdef.h #included from vmsish.h */
1840 #  else
1841     ABORT();            /* for use with undump */
1842 #  endif
1843 #endif
1844 }
1845
1846 /* initialize curinterp */
1847 STATIC void
1848 S_init_interp(pTHX)
1849 {
1850
1851 #ifdef PERL_OBJECT              /* XXX kludge */
1852 #define I_REINIT \
1853   STMT_START {                          \
1854     PL_chopset          = " \n-";       \
1855     PL_copline          = NOLINE;       \
1856     PL_curcop           = &PL_compiling;\
1857     PL_curcopdb         = NULL;         \
1858     PL_dbargs           = 0;            \
1859     PL_dlmax            = 128;          \
1860     PL_dumpindent       = 4;            \
1861     PL_laststatval      = -1;           \
1862     PL_laststype        = OP_STAT;      \
1863     PL_maxscream        = -1;           \
1864     PL_maxsysfd         = MAXSYSFD;     \
1865     PL_statname         = Nullsv;       \
1866     PL_tmps_floor       = -1;           \
1867     PL_tmps_ix          = -1;           \
1868     PL_op_mask          = NULL;         \
1869     PL_dlmax            = 128;          \
1870     PL_laststatval      = -1;           \
1871     PL_laststype        = OP_STAT;      \
1872     PL_mess_sv          = Nullsv;       \
1873     PL_splitstr         = " ";          \
1874     PL_generation       = 100;          \
1875     PL_exitlist         = NULL;         \
1876     PL_exitlistlen      = 0;            \
1877     PL_regindent        = 0;            \
1878     PL_in_clean_objs    = FALSE;        \
1879     PL_in_clean_all     = FALSE;        \
1880     PL_profiledata      = NULL;         \
1881     PL_rsfp             = Nullfp;       \
1882     PL_rsfp_filters     = Nullav;       \
1883     PL_dirty            = FALSE;        \
1884   } STMT_END
1885     I_REINIT;
1886 #else
1887 #  ifdef MULTIPLICITY
1888 #    define PERLVAR(var,type)
1889 #    define PERLVARA(var,n,type)
1890 #    if defined(PERL_IMPLICIT_CONTEXT)
1891 #      if defined(USE_THREADS)
1892 #        define PERLVARI(var,type,init)         PERL_GET_INTERP->var = init;
1893 #        define PERLVARIC(var,type,init)        PERL_GET_INTERP->var = init;
1894 #      else /* !USE_THREADS */
1895 #        define PERLVARI(var,type,init)         aTHX->var = init;
1896 #        define PERLVARIC(var,type,init)        aTHX->var = init;
1897 #      endif /* USE_THREADS */
1898 #    else
1899 #      define PERLVARI(var,type,init)   PERL_GET_INTERP->var = init;
1900 #      define PERLVARIC(var,type,init)  PERL_GET_INTERP->var = init;
1901 #    endif
1902 #    include "intrpvar.h"
1903 #    ifndef USE_THREADS
1904 #      include "thrdvar.h"
1905 #    endif
1906 #    undef PERLVAR
1907 #    undef PERLVARA
1908 #    undef PERLVARI
1909 #    undef PERLVARIC
1910 #  else
1911 #    define PERLVAR(var,type)
1912 #    define PERLVARA(var,n,type)
1913 #    define PERLVARI(var,type,init)     PL_##var = init;
1914 #    define PERLVARIC(var,type,init)    PL_##var = init;
1915 #    include "intrpvar.h"
1916 #    ifndef USE_THREADS
1917 #      include "thrdvar.h"
1918 #    endif
1919 #    undef PERLVAR
1920 #    undef PERLVARA
1921 #    undef PERLVARI
1922 #    undef PERLVARIC
1923 #  endif
1924 #endif
1925
1926 }
1927
1928 STATIC void
1929 S_init_main_stash(pTHX)
1930 {
1931     dTHR;
1932     GV *gv;
1933
1934     /* Note that strtab is a rather special HV.  Assumptions are made
1935        about not iterating on it, and not adding tie magic to it.
1936        It is properly deallocated in perl_destruct() */
1937     PL_strtab = newHV();
1938 #ifdef USE_THREADS
1939     MUTEX_INIT(&PL_strtab_mutex);
1940 #endif
1941     HvSHAREKEYS_off(PL_strtab);                 /* mandatory */
1942     hv_ksplit(PL_strtab, 512);
1943
1944     PL_curstash = PL_defstash = newHV();
1945     PL_curstname = newSVpvn("main",4);
1946     gv = gv_fetchpv("main::",TRUE, SVt_PVHV);
1947     SvREFCNT_dec(GvHV(gv));
1948     GvHV(gv) = (HV*)SvREFCNT_inc(PL_defstash);
1949     SvREADONLY_on(gv);
1950     HvNAME(PL_defstash) = savepv("main");
1951     PL_incgv = gv_HVadd(gv_AVadd(gv_fetchpv("INC",TRUE, SVt_PVAV)));
1952     GvMULTI_on(PL_incgv);
1953     PL_hintgv = gv_fetchpv("\010",TRUE, SVt_PV); /* ^H */
1954     GvMULTI_on(PL_hintgv);
1955     PL_defgv = gv_fetchpv("_",TRUE, SVt_PVAV);
1956     PL_errgv = gv_HVadd(gv_fetchpv("@", TRUE, SVt_PV));
1957     GvMULTI_on(PL_errgv);
1958     PL_replgv = gv_fetchpv("\022", TRUE, SVt_PV); /* ^R */
1959     GvMULTI_on(PL_replgv);
1960     (void)Perl_form(aTHX_ "%240s","");  /* Preallocate temp - for immediate signals. */
1961     sv_grow(ERRSV, 240);        /* Preallocate - for immediate signals. */
1962     sv_setpvn(ERRSV, "", 0);
1963     PL_curstash = PL_defstash;
1964     PL_compiling.cop_stash = PL_defstash;
1965     PL_debstash = GvHV(gv_fetchpv("DB::", GV_ADDMULTI, SVt_PVHV));
1966     PL_globalstash = GvHV(gv_fetchpv("CORE::GLOBAL::", GV_ADDMULTI, SVt_PVHV));
1967     /* We must init $/ before switches are processed. */
1968     sv_setpvn(get_sv("/", TRUE), "\n", 1);
1969 }
1970
1971 STATIC void
1972 S_open_script(pTHX_ char *scriptname, bool dosearch, SV *sv, int *fdscript)
1973 {
1974     dTHR;
1975     register char *s;
1976
1977     *fdscript = -1;
1978
1979     if (PL_e_script) {
1980         PL_origfilename = savepv("-e");
1981     }
1982     else {
1983         /* if find_script() returns, it returns a malloc()-ed value */
1984         PL_origfilename = scriptname = find_script(scriptname, dosearch, NULL, 1);
1985
1986         if (strnEQ(scriptname, "/dev/fd/", 8) && isDIGIT(scriptname[8]) ) {
1987             char *s = scriptname + 8;
1988             *fdscript = atoi(s);
1989             while (isDIGIT(*s))
1990                 s++;
1991             if (*s) {
1992                 scriptname = savepv(s + 1);
1993                 Safefree(PL_origfilename);
1994                 PL_origfilename = scriptname;
1995             }
1996         }
1997     }
1998
1999     PL_curcop->cop_filegv = gv_fetchfile(PL_origfilename);
2000     if (strEQ(PL_origfilename,"-"))
2001         scriptname = "";
2002     if (*fdscript >= 0) {
2003         PL_rsfp = PerlIO_fdopen(*fdscript,PERL_SCRIPT_MODE);
2004 #if defined(HAS_FCNTL) && defined(F_SETFD)
2005         if (PL_rsfp)
2006             fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,1);  /* ensure close-on-exec */
2007 #endif
2008     }
2009     else if (PL_preprocess) {
2010         char *cpp_cfg = CPPSTDIN;
2011         SV *cpp = newSVpvn("",0);
2012         SV *cmd = NEWSV(0,0);
2013
2014         if (strEQ(cpp_cfg, "cppstdin"))
2015             Perl_sv_catpvf(aTHX_ cpp, "%s/", BIN_EXP);
2016         sv_catpv(cpp, cpp_cfg);
2017
2018         sv_catpv(sv,"-I");
2019         sv_catpv(sv,PRIVLIB_EXP);
2020
2021 #ifdef MSDOS
2022         Perl_sv_setpvf(aTHX_ cmd, "\
2023 sed %s -e \"/^[^#]/b\" \
2024  -e \"/^#[      ]*include[      ]/b\" \
2025  -e \"/^#[      ]*define[       ]/b\" \
2026  -e \"/^#[      ]*if[   ]/b\" \
2027  -e \"/^#[      ]*ifdef[        ]/b\" \
2028  -e \"/^#[      ]*ifndef[       ]/b\" \
2029  -e \"/^#[      ]*else/b\" \
2030  -e \"/^#[      ]*elif[         ]/b\" \
2031  -e \"/^#[      ]*undef[        ]/b\" \
2032  -e \"/^#[      ]*endif/b\" \
2033  -e \"s/^#.*//\" \
2034  %s | %_ -C %_ %s",
2035           (PL_doextract ? "-e \"1,/^#/d\n\"" : ""),
2036 #else
2037 #  ifdef __OPEN_VM
2038         Perl_sv_setpvf(aTHX_ cmd, "\
2039 %s %s -e '/^[^#]/b' \
2040  -e '/^#[       ]*include[      ]/b' \
2041  -e '/^#[       ]*define[       ]/b' \
2042  -e '/^#[       ]*if[   ]/b' \
2043  -e '/^#[       ]*ifdef[        ]/b' \
2044  -e '/^#[       ]*ifndef[       ]/b' \
2045  -e '/^#[       ]*else/b' \
2046  -e '/^#[       ]*elif[         ]/b' \
2047  -e '/^#[       ]*undef[        ]/b' \
2048  -e '/^#[       ]*endif/b' \
2049  -e 's/^[       ]*#.*//' \
2050  %s | %_ %_ %s",
2051 #  else
2052         Perl_sv_setpvf(aTHX_ cmd, "\
2053 %s %s -e '/^[^#]/b' \
2054  -e '/^#[       ]*include[      ]/b' \
2055  -e '/^#[       ]*define[       ]/b' \
2056  -e '/^#[       ]*if[   ]/b' \
2057  -e '/^#[       ]*ifdef[        ]/b' \
2058  -e '/^#[       ]*ifndef[       ]/b' \
2059  -e '/^#[       ]*else/b' \
2060  -e '/^#[       ]*elif[         ]/b' \
2061  -e '/^#[       ]*undef[        ]/b' \
2062  -e '/^#[       ]*endif/b' \
2063  -e 's/^[       ]*#.*//' \
2064  %s | %_ -C %_ %s",
2065 #  endif
2066 #ifdef LOC_SED
2067           LOC_SED,
2068 #else
2069           "sed",
2070 #endif
2071           (PL_doextract ? "-e '1,/^#/d\n'" : ""),
2072 #endif
2073           scriptname, cpp, sv, CPPMINUS);
2074         PL_doextract = FALSE;
2075 #ifdef IAMSUID                          /* actually, this is caught earlier */
2076         if (PL_euid != PL_uid && !PL_euid) {    /* if running suidperl */
2077 #ifdef HAS_SETEUID
2078             (void)seteuid(PL_uid);              /* musn't stay setuid root */
2079 #else
2080 #ifdef HAS_SETREUID
2081             (void)setreuid((Uid_t)-1, PL_uid);
2082 #else
2083 #ifdef HAS_SETRESUID
2084             (void)setresuid((Uid_t)-1, PL_uid, (Uid_t)-1);
2085 #else
2086             PerlProc_setuid(PL_uid);
2087 #endif
2088 #endif
2089 #endif
2090             if (PerlProc_geteuid() != PL_uid)
2091                 Perl_croak(aTHX_ "Can't do seteuid!\n");
2092         }
2093 #endif /* IAMSUID */
2094         PL_rsfp = PerlProc_popen(SvPVX(cmd), "r");
2095         SvREFCNT_dec(cmd);
2096         SvREFCNT_dec(cpp);
2097     }
2098     else if (!*scriptname) {
2099         forbid_setid("program input from stdin");
2100         PL_rsfp = PerlIO_stdin();
2101     }
2102     else {
2103         PL_rsfp = PerlIO_open(scriptname,PERL_SCRIPT_MODE);
2104 #if defined(HAS_FCNTL) && defined(F_SETFD)
2105         if (PL_rsfp)
2106             fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,1);  /* ensure close-on-exec */
2107 #endif
2108     }
2109     if (!PL_rsfp) {
2110 #ifdef DOSUID
2111 #ifndef IAMSUID         /* in case script is not readable before setuid */
2112         if (PL_euid &&
2113             PerlLIO_stat(SvPVX(GvSV(PL_curcop->cop_filegv)),&PL_statbuf) >= 0 &&
2114             PL_statbuf.st_mode & (S_ISUID|S_ISGID))
2115         {
2116             /* try again */
2117             PerlProc_execv(Perl_form(aTHX_ "%s/sperl%s", BIN_EXP, PL_patchlevel), PL_origargv);
2118             Perl_croak(aTHX_ "Can't do setuid\n");
2119         }
2120 #endif
2121 #endif
2122         Perl_croak(aTHX_ "Can't open perl script \"%s\": %s\n",
2123           SvPVX(GvSV(PL_curcop->cop_filegv)), Strerror(errno));
2124     }
2125 }
2126
2127 /* Mention
2128  * I_SYSSTATVFS HAS_FSTATVFS
2129  * I_SYSMOUNT
2130  * I_STATFS     HAS_FSTATFS
2131  * I_MNTENT     HAS_GETMNTENT   HAS_HASMNTOPT
2132  * here so that metaconfig picks them up. */
2133
2134 #ifdef IAMSUID
2135 STATIC int
2136 S_fd_on_nosuid_fs(pTHX_ int fd)
2137 {
2138     int on_nosuid  = 0;
2139     int check_okay = 0;
2140 /*
2141  * Preferred order: fstatvfs(), fstatfs(), getmntent().
2142  * fstatvfs() is UNIX98.
2143  * fstatfs() is BSD.
2144  * getmntent() is O(number-of-mounted-filesystems) and can hang.
2145  */
2146
2147 #   ifdef HAS_FSTATVFS
2148     struct statvfs stfs;
2149     check_okay = fstatvfs(fd, &stfs) == 0;
2150     on_nosuid  = check_okay && (stfs.f_flag  & ST_NOSUID);
2151 #   else
2152 #       if defined(HAS_FSTATFS) && defined(HAS_STRUCT_STATFS_FLAGS)
2153     struct statfs  stfs;
2154     check_okay = fstatfs(fd, &stfs)  == 0;
2155 #           undef PERL_MOUNT_NOSUID
2156 #           if !defined(PERL_MOUNT_NOSUID) && defined(MNT_NOSUID)
2157 #              define PERL_MOUNT_NOSUID MNT_NOSUID
2158 #           endif
2159 #           if !defined(PERL_MOUNT_NOSUID) && defined(MS_NOSUID)
2160 #              define PERL_MOUNT_NOSUID MS_NOSUID
2161 #           endif
2162 #           if !defined(PERL_MOUNT_NOSUID) && defined(M_NOSUID)
2163 #              define PERL_MOUNT_NOSUID M_NOSUID
2164 #           endif
2165 #           ifdef PERL_MOUNT_NOSUID
2166     on_nosuid  = check_okay && (stfs.f_flags & PERL_MOUNT_NOSUID);
2167 #           endif
2168 #       else
2169 #           if defined(HAS_GETMNTENT) && defined(HAS_HASMNTOPT) && defined(MNTOPT_NOSUID)
2170     FILE                *mtab = fopen("/etc/mtab", "r");
2171     struct mntent       *entry;
2172     struct stat         stb, fsb;
2173
2174     if (mtab && (fstat(fd, &stb) == 0)) {
2175         while (entry = getmntent(mtab)) {
2176             if (stat(entry->mnt_dir, &fsb) == 0
2177                 && fsb.st_dev == stb.st_dev)
2178             {
2179                 /* found the filesystem */
2180                 check_okay = 1;
2181                 if (hasmntopt(entry, MNTOPT_NOSUID))
2182                     on_nosuid = 1;
2183                 break;
2184             } /* A single fs may well fail its stat(). */
2185         }
2186     }
2187     if (mtab)
2188         fclose(mtab);
2189 #           endif /* mntent */
2190 #       endif /* statfs */
2191 #   endif /* statvfs */
2192     if (!check_okay)
2193         Perl_croak(aTHX_ "Can't check filesystem of script \"%s\"", PL_origfilename);
2194     return on_nosuid;
2195 }
2196 #endif /* IAMSUID */
2197
2198 STATIC void
2199 S_validate_suid(pTHX_ char *validarg, char *scriptname, int fdscript)
2200 {
2201     int which;
2202
2203     /* do we need to emulate setuid on scripts? */
2204
2205     /* This code is for those BSD systems that have setuid #! scripts disabled
2206      * in the kernel because of a security problem.  Merely defining DOSUID
2207      * in perl will not fix that problem, but if you have disabled setuid
2208      * scripts in the kernel, this will attempt to emulate setuid and setgid
2209      * on scripts that have those now-otherwise-useless bits set.  The setuid
2210      * root version must be called suidperl or sperlN.NNN.  If regular perl
2211      * discovers that it has opened a setuid script, it calls suidperl with
2212      * the same argv that it had.  If suidperl finds that the script it has
2213      * just opened is NOT setuid root, it sets the effective uid back to the
2214      * uid.  We don't just make perl setuid root because that loses the
2215      * effective uid we had before invoking perl, if it was different from the
2216      * uid.
2217      *
2218      * DOSUID must be defined in both perl and suidperl, and IAMSUID must
2219      * be defined in suidperl only.  suidperl must be setuid root.  The
2220      * Configure script will set this up for you if you want it.
2221      */
2222
2223 #ifdef DOSUID
2224     dTHR;
2225     char *s, *s2;
2226
2227     if (PerlLIO_fstat(PerlIO_fileno(PL_rsfp),&PL_statbuf) < 0)  /* normal stat is insecure */
2228         Perl_croak(aTHX_ "Can't stat script \"%s\"",PL_origfilename);
2229     if (fdscript < 0 && PL_statbuf.st_mode & (S_ISUID|S_ISGID)) {
2230         I32 len;
2231         STRLEN n_a;
2232
2233 #ifdef IAMSUID
2234 #ifndef HAS_SETREUID
2235         /* On this access check to make sure the directories are readable,
2236          * there is actually a small window that the user could use to make
2237          * filename point to an accessible directory.  So there is a faint
2238          * chance that someone could execute a setuid script down in a
2239          * non-accessible directory.  I don't know what to do about that.
2240          * But I don't think it's too important.  The manual lies when
2241          * it says access() is useful in setuid programs.
2242          */
2243         if (PerlLIO_access(SvPVX(GvSV(PL_curcop->cop_filegv)),1)) /*double check*/
2244             Perl_croak(aTHX_ "Permission denied");
2245 #else
2246         /* If we can swap euid and uid, then we can determine access rights
2247          * with a simple stat of the file, and then compare device and
2248          * inode to make sure we did stat() on the same file we opened.
2249          * Then we just have to make sure he or she can execute it.
2250          */
2251         {
2252             struct stat tmpstatbuf;
2253
2254             if (
2255 #ifdef HAS_SETREUID
2256                 setreuid(PL_euid,PL_uid) < 0
2257 #else
2258 # if HAS_SETRESUID
2259                 setresuid(PL_euid,PL_uid,(Uid_t)-1) < 0
2260 # endif
2261 #endif
2262                 || PerlProc_getuid() != PL_euid || PerlProc_geteuid() != PL_uid)
2263                 Perl_croak(aTHX_ "Can't swap uid and euid");    /* really paranoid */
2264             if (PerlLIO_stat(SvPVX(GvSV(PL_curcop->cop_filegv)),&tmpstatbuf) < 0)
2265                 Perl_croak(aTHX_ "Permission denied");  /* testing full pathname here */
2266 #if defined(IAMSUID) && !defined(NO_NOSUID_CHECK)
2267             if (fd_on_nosuid_fs(PerlIO_fileno(PL_rsfp)))
2268                 Perl_croak(aTHX_ "Permission denied");
2269 #endif
2270             if (tmpstatbuf.st_dev != PL_statbuf.st_dev ||
2271                 tmpstatbuf.st_ino != PL_statbuf.st_ino) {
2272                 (void)PerlIO_close(PL_rsfp);
2273                 if (PL_rsfp = PerlProc_popen("/bin/mail root","w")) {   /* heh, heh */
2274                     PerlIO_printf(PL_rsfp,
2275 "User %ld tried to run dev %ld ino %ld in place of dev %ld ino %ld!\n\
2276 (Filename of set-id script was %s, uid %ld gid %ld.)\n\nSincerely,\nperl\n",
2277                         (long)PL_uid,(long)tmpstatbuf.st_dev, (long)tmpstatbuf.st_ino,
2278                         (long)PL_statbuf.st_dev, (long)PL_statbuf.st_ino,
2279                         SvPVX(GvSV(PL_curcop->cop_filegv)),
2280                         (long)PL_statbuf.st_uid, (long)PL_statbuf.st_gid);
2281                     (void)PerlProc_pclose(PL_rsfp);
2282                 }
2283                 Perl_croak(aTHX_ "Permission denied\n");
2284             }
2285             if (
2286 #ifdef HAS_SETREUID
2287               setreuid(PL_uid,PL_euid) < 0
2288 #else
2289 # if defined(HAS_SETRESUID)
2290               setresuid(PL_uid,PL_euid,(Uid_t)-1) < 0
2291 # endif
2292 #endif
2293               || PerlProc_getuid() != PL_uid || PerlProc_geteuid() != PL_euid)
2294                 Perl_croak(aTHX_ "Can't reswap uid and euid");
2295             if (!cando(S_IXUSR,FALSE,&PL_statbuf))              /* can real uid exec? */
2296                 Perl_croak(aTHX_ "Permission denied\n");
2297         }
2298 #endif /* HAS_SETREUID */
2299 #endif /* IAMSUID */
2300
2301         if (!S_ISREG(PL_statbuf.st_mode))
2302             Perl_croak(aTHX_ "Permission denied");
2303         if (PL_statbuf.st_mode & S_IWOTH)
2304             Perl_croak(aTHX_ "Setuid/gid script is writable by world");
2305         PL_doswitches = FALSE;          /* -s is insecure in suid */
2306         PL_curcop->cop_line++;
2307         if (sv_gets(PL_linestr, PL_rsfp, 0) == Nullch ||
2308           strnNE(SvPV(PL_linestr,n_a),"#!",2) ) /* required even on Sys V */
2309             Perl_croak(aTHX_ "No #! line");
2310         s = SvPV(PL_linestr,n_a)+2;
2311         if (*s == ' ') s++;
2312         while (!isSPACE(*s)) s++;
2313         for (s2 = s;  (s2 > SvPV(PL_linestr,n_a)+2 &&
2314                        (isDIGIT(s2[-1]) || strchr("._-", s2[-1])));  s2--) ;
2315         if (strnNE(s2-4,"perl",4) && strnNE(s-9,"perl",4))  /* sanity check */
2316             Perl_croak(aTHX_ "Not a perl script");
2317         while (*s == ' ' || *s == '\t') s++;
2318         /*
2319          * #! arg must be what we saw above.  They can invoke it by
2320          * mentioning suidperl explicitly, but they may not add any strange
2321          * arguments beyond what #! says if they do invoke suidperl that way.
2322          */
2323         len = strlen(validarg);
2324         if (strEQ(validarg," PHOOEY ") ||
2325             strnNE(s,validarg,len) || !isSPACE(s[len]))
2326             Perl_croak(aTHX_ "Args must match #! line");
2327
2328 #ifndef IAMSUID
2329         if (PL_euid != PL_uid && (PL_statbuf.st_mode & S_ISUID) &&
2330             PL_euid == PL_statbuf.st_uid)
2331             if (!PL_do_undump)
2332                 Perl_croak(aTHX_ "YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
2333 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
2334 #endif /* IAMSUID */
2335
2336         if (PL_euid) {  /* oops, we're not the setuid root perl */
2337             (void)PerlIO_close(PL_rsfp);
2338 #ifndef IAMSUID
2339             /* try again */
2340             PerlProc_execv(Perl_form(aTHX_ "%s/sperl%s", BIN_EXP, PL_patchlevel), PL_origargv);
2341 #endif
2342             Perl_croak(aTHX_ "Can't do setuid\n");
2343         }
2344
2345         if (PL_statbuf.st_mode & S_ISGID && PL_statbuf.st_gid != PL_egid) {
2346 #ifdef HAS_SETEGID
2347             (void)setegid(PL_statbuf.st_gid);
2348 #else
2349 #ifdef HAS_SETREGID
2350            (void)setregid((Gid_t)-1,PL_statbuf.st_gid);
2351 #else
2352 #ifdef HAS_SETRESGID
2353            (void)setresgid((Gid_t)-1,PL_statbuf.st_gid,(Gid_t)-1);
2354 #else
2355             PerlProc_setgid(PL_statbuf.st_gid);
2356 #endif
2357 #endif
2358 #endif
2359             if (PerlProc_getegid() != PL_statbuf.st_gid)
2360                 Perl_croak(aTHX_ "Can't do setegid!\n");
2361         }
2362         if (PL_statbuf.st_mode & S_ISUID) {
2363             if (PL_statbuf.st_uid != PL_euid)
2364 #ifdef HAS_SETEUID
2365                 (void)seteuid(PL_statbuf.st_uid);       /* all that for this */
2366 #else
2367 #ifdef HAS_SETREUID
2368                 (void)setreuid((Uid_t)-1,PL_statbuf.st_uid);
2369 #else
2370 #ifdef HAS_SETRESUID
2371                 (void)setresuid((Uid_t)-1,PL_statbuf.st_uid,(Uid_t)-1);
2372 #else
2373                 PerlProc_setuid(PL_statbuf.st_uid);
2374 #endif
2375 #endif
2376 #endif
2377             if (PerlProc_geteuid() != PL_statbuf.st_uid)
2378                 Perl_croak(aTHX_ "Can't do seteuid!\n");
2379         }
2380         else if (PL_uid) {                      /* oops, mustn't run as root */
2381 #ifdef HAS_SETEUID
2382           (void)seteuid((Uid_t)PL_uid);
2383 #else
2384 #ifdef HAS_SETREUID
2385           (void)setreuid((Uid_t)-1,(Uid_t)PL_uid);
2386 #else
2387 #ifdef HAS_SETRESUID
2388           (void)setresuid((Uid_t)-1,(Uid_t)PL_uid,(Uid_t)-1);
2389 #else
2390           PerlProc_setuid((Uid_t)PL_uid);
2391 #endif
2392 #endif
2393 #endif
2394             if (PerlProc_geteuid() != PL_uid)
2395                 Perl_croak(aTHX_ "Can't do seteuid!\n");
2396         }
2397         init_ids();
2398         if (!cando(S_IXUSR,TRUE,&PL_statbuf))
2399             Perl_croak(aTHX_ "Permission denied\n");    /* they can't do this */
2400     }
2401 #ifdef IAMSUID
2402     else if (PL_preprocess)
2403         Perl_croak(aTHX_ "-P not allowed for setuid/setgid script\n");
2404     else if (fdscript >= 0)
2405         Perl_croak(aTHX_ "fd script not allowed in suidperl\n");
2406     else
2407         Perl_croak(aTHX_ "Script is not setuid/setgid in suidperl\n");
2408
2409     /* We absolutely must clear out any saved ids here, so we */
2410     /* exec the real perl, substituting fd script for scriptname. */
2411     /* (We pass script name as "subdir" of fd, which perl will grok.) */
2412     PerlIO_rewind(PL_rsfp);
2413     PerlLIO_lseek(PerlIO_fileno(PL_rsfp),(Off_t)0,0);  /* just in case rewind didn't */
2414     for (which = 1; PL_origargv[which] && PL_origargv[which] != scriptname; which++) ;
2415     if (!PL_origargv[which])
2416         Perl_croak(aTHX_ "Permission denied");
2417     PL_origargv[which] = savepv(Perl_form(aTHX_ "/dev/fd/%d/%s",
2418                                   PerlIO_fileno(PL_rsfp), PL_origargv[which]));
2419 #if defined(HAS_FCNTL) && defined(F_SETFD)
2420     fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,0);    /* ensure no close-on-exec */
2421 #endif
2422     PerlProc_execv(Perl_form(aTHX_ "%s/perl%s", BIN_EXP, PL_patchlevel), PL_origargv);/* try again */
2423     Perl_croak(aTHX_ "Can't do setuid\n");
2424 #endif /* IAMSUID */
2425 #else /* !DOSUID */
2426     if (PL_euid != PL_uid || PL_egid != PL_gid) {       /* (suidperl doesn't exist, in fact) */
2427 #ifndef SETUID_SCRIPTS_ARE_SECURE_NOW
2428         dTHR;
2429         PerlLIO_fstat(PerlIO_fileno(PL_rsfp),&PL_statbuf);      /* may be either wrapped or real suid */
2430         if ((PL_euid != PL_uid && PL_euid == PL_statbuf.st_uid && PL_statbuf.st_mode & S_ISUID)
2431             ||
2432             (PL_egid != PL_gid && PL_egid == PL_statbuf.st_gid && PL_statbuf.st_mode & S_ISGID)
2433            )
2434             if (!PL_do_undump)
2435                 Perl_croak(aTHX_ "YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
2436 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
2437 #endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
2438         /* not set-id, must be wrapped */
2439     }
2440 #endif /* DOSUID */
2441 }
2442
2443 STATIC void
2444 S_find_beginning(pTHX)
2445 {
2446     register char *s, *s2;
2447
2448     /* skip forward in input to the real script? */
2449
2450     forbid_setid("-x");
2451     while (PL_doextract) {
2452         if ((s = sv_gets(PL_linestr, PL_rsfp, 0)) == Nullch)
2453             Perl_croak(aTHX_ "No Perl script found in input\n");
2454         if (*s == '#' && s[1] == '!' && (s = instr(s,"perl"))) {
2455             PerlIO_ungetc(PL_rsfp, '\n');               /* to keep line count right */
2456             PL_doextract = FALSE;
2457             while (*s && !(isSPACE (*s) || *s == '#')) s++;
2458             s2 = s;
2459             while (*s == ' ' || *s == '\t') s++;
2460             if (*s++ == '-') {
2461                 while (isDIGIT(s2[-1]) || strchr("-._", s2[-1])) s2--;
2462                 if (strnEQ(s2-4,"perl",4))
2463                     /*SUPPRESS 530*/
2464                     while (s = moreswitches(s)) ;
2465             }
2466             if (PL_cddir && PerlDir_chdir(PL_cddir) < 0)
2467                 Perl_croak(aTHX_ "Can't chdir to %s",PL_cddir);
2468         }
2469     }
2470 }
2471
2472
2473 STATIC void
2474 S_init_ids(pTHX)
2475 {
2476     PL_uid = PerlProc_getuid();
2477     PL_euid = PerlProc_geteuid();
2478     PL_gid = PerlProc_getgid();
2479     PL_egid = PerlProc_getegid();
2480 #ifdef VMS
2481     PL_uid |= PL_gid << 16;
2482     PL_euid |= PL_egid << 16;
2483 #endif
2484     PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2485 }
2486
2487 STATIC void
2488 S_forbid_setid(pTHX_ char *s)
2489 {
2490     if (PL_euid != PL_uid)
2491         Perl_croak(aTHX_ "No %s allowed while running setuid", s);
2492     if (PL_egid != PL_gid)
2493         Perl_croak(aTHX_ "No %s allowed while running setgid", s);
2494 }
2495
2496 void
2497 Perl_init_debugger(pTHX)
2498 {
2499     dTHR;
2500     HV *ostash = PL_curstash;
2501
2502     PL_curstash = PL_debstash;
2503     PL_dbargs = GvAV(gv_AVadd((gv_fetchpv("args", GV_ADDMULTI, SVt_PVAV))));
2504     AvREAL_off(PL_dbargs);
2505     PL_DBgv = gv_fetchpv("DB", GV_ADDMULTI, SVt_PVGV);
2506     PL_DBline = gv_fetchpv("dbline", GV_ADDMULTI, SVt_PVAV);
2507     PL_DBsub = gv_HVadd(gv_fetchpv("sub", GV_ADDMULTI, SVt_PVHV));
2508     sv_upgrade(GvSV(PL_DBsub), SVt_IV); /* IVX accessed if PERLDB_SUB_NN */
2509     PL_DBsingle = GvSV((gv_fetchpv("single", GV_ADDMULTI, SVt_PV)));
2510     sv_setiv(PL_DBsingle, 0);
2511     PL_DBtrace = GvSV((gv_fetchpv("trace", GV_ADDMULTI, SVt_PV)));
2512     sv_setiv(PL_DBtrace, 0);
2513     PL_DBsignal = GvSV((gv_fetchpv("signal", GV_ADDMULTI, SVt_PV)));
2514     sv_setiv(PL_DBsignal, 0);
2515     PL_curstash = ostash;
2516 }
2517
2518 #ifndef STRESS_REALLOC
2519 #define REASONABLE(size) (size)
2520 #else
2521 #define REASONABLE(size) (1) /* unreasonable */
2522 #endif
2523
2524 void
2525 Perl_init_stacks(pTHX)
2526 {
2527     /* start with 128-item stack and 8K cxstack */
2528     PL_curstackinfo = new_stackinfo(REASONABLE(128),
2529                                  REASONABLE(8192/sizeof(PERL_CONTEXT) - 1));
2530     PL_curstackinfo->si_type = PERLSI_MAIN;
2531     PL_curstack = PL_curstackinfo->si_stack;
2532     PL_mainstack = PL_curstack;         /* remember in case we switch stacks */
2533
2534     PL_stack_base = AvARRAY(PL_curstack);
2535     PL_stack_sp = PL_stack_base;
2536     PL_stack_max = PL_stack_base + AvMAX(PL_curstack);
2537
2538     New(50,PL_tmps_stack,REASONABLE(128),SV*);
2539     PL_tmps_floor = -1;
2540     PL_tmps_ix = -1;
2541     PL_tmps_max = REASONABLE(128);
2542
2543     New(54,PL_markstack,REASONABLE(32),I32);
2544     PL_markstack_ptr = PL_markstack;
2545     PL_markstack_max = PL_markstack + REASONABLE(32);
2546
2547     SET_MARKBASE;
2548
2549     New(54,PL_scopestack,REASONABLE(32),I32);
2550     PL_scopestack_ix = 0;
2551     PL_scopestack_max = REASONABLE(32);
2552
2553     New(54,PL_savestack,REASONABLE(128),ANY);
2554     PL_savestack_ix = 0;
2555     PL_savestack_max = REASONABLE(128);
2556
2557     New(54,PL_retstack,REASONABLE(16),OP*);
2558     PL_retstack_ix = 0;
2559     PL_retstack_max = REASONABLE(16);
2560 }
2561
2562 #undef REASONABLE
2563
2564 STATIC void
2565 S_nuke_stacks(pTHX)
2566 {
2567     dTHR;
2568     while (PL_curstackinfo->si_next)
2569         PL_curstackinfo = PL_curstackinfo->si_next;
2570     while (PL_curstackinfo) {
2571         PERL_SI *p = PL_curstackinfo->si_prev;
2572         /* curstackinfo->si_stack got nuked by sv_free_arenas() */
2573         Safefree(PL_curstackinfo->si_cxstack);
2574         Safefree(PL_curstackinfo);
2575         PL_curstackinfo = p;
2576     }
2577     Safefree(PL_tmps_stack);
2578     Safefree(PL_markstack);
2579     Safefree(PL_scopestack);
2580     Safefree(PL_savestack);
2581     Safefree(PL_retstack);
2582     DEBUG( {
2583         Safefree(PL_debname);
2584         Safefree(PL_debdelim);
2585     } )
2586 }
2587
2588 #ifndef PERL_OBJECT
2589 static PerlIO *tmpfp;  /* moved outside init_lexer() because of UNICOS bug */
2590 #endif
2591
2592 STATIC void
2593 S_init_lexer(pTHX)
2594 {
2595 #ifdef PERL_OBJECT
2596         PerlIO *tmpfp;
2597 #endif
2598     tmpfp = PL_rsfp;
2599     PL_rsfp = Nullfp;
2600     lex_start(PL_linestr);
2601     PL_rsfp = tmpfp;
2602     PL_subname = newSVpvn("main",4);
2603 }
2604
2605 STATIC void
2606 S_init_predump_symbols(pTHX)
2607 {
2608     dTHR;
2609     GV *tmpgv;
2610     GV *othergv;
2611     IO *io;
2612
2613     sv_setpvn(get_sv("\"", TRUE), " ", 1);
2614     PL_stdingv = gv_fetchpv("STDIN",TRUE, SVt_PVIO);
2615     GvMULTI_on(PL_stdingv);
2616     io = GvIOp(PL_stdingv);
2617     IoIFP(io) = PerlIO_stdin();
2618     tmpgv = gv_fetchpv("stdin",TRUE, SVt_PV);
2619     GvMULTI_on(tmpgv);
2620     GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io);
2621
2622     tmpgv = gv_fetchpv("STDOUT",TRUE, SVt_PVIO);
2623     GvMULTI_on(tmpgv);
2624     io = GvIOp(tmpgv);
2625     IoOFP(io) = IoIFP(io) = PerlIO_stdout();
2626     setdefout(tmpgv);
2627     tmpgv = gv_fetchpv("stdout",TRUE, SVt_PV);
2628     GvMULTI_on(tmpgv);
2629     GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io);
2630
2631     othergv = gv_fetchpv("STDERR",TRUE, SVt_PVIO);
2632     GvMULTI_on(othergv);
2633     io = GvIOp(othergv);
2634     IoOFP(io) = IoIFP(io) = PerlIO_stderr();
2635     tmpgv = gv_fetchpv("stderr",TRUE, SVt_PV);
2636     GvMULTI_on(tmpgv);
2637     GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io);
2638
2639     PL_statname = NEWSV(66,0);          /* last filename we did stat on */
2640
2641     if (!PL_osname)
2642         PL_osname = savepv(OSNAME);
2643 }
2644
2645 STATIC void
2646 S_init_postdump_symbols(pTHX_ register int argc, register char **argv, register char **env)
2647 {
2648     dTHR;
2649     char *s;
2650     SV *sv;
2651     GV* tmpgv;
2652
2653     argc--,argv++;      /* skip name of script */
2654     if (PL_doswitches) {
2655         for (; argc > 0 && **argv == '-'; argc--,argv++) {
2656             if (!argv[0][1])
2657                 break;
2658             if (argv[0][1] == '-') {
2659                 argc--,argv++;
2660                 break;
2661             }
2662             if (s = strchr(argv[0], '=')) {
2663                 *s++ = '\0';
2664                 sv_setpv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),s);
2665             }
2666             else
2667                 sv_setiv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),1);
2668         }
2669     }
2670     PL_toptarget = NEWSV(0,0);
2671     sv_upgrade(PL_toptarget, SVt_PVFM);
2672     sv_setpvn(PL_toptarget, "", 0);
2673     PL_bodytarget = NEWSV(0,0);
2674     sv_upgrade(PL_bodytarget, SVt_PVFM);
2675     sv_setpvn(PL_bodytarget, "", 0);
2676     PL_formtarget = PL_bodytarget;
2677
2678     TAINT;
2679     if (tmpgv = gv_fetchpv("0",TRUE, SVt_PV)) {
2680         sv_setpv(GvSV(tmpgv),PL_origfilename);
2681         magicname("0", "0", 1);
2682     }
2683     if (tmpgv = gv_fetchpv("\030",TRUE, SVt_PV))
2684         sv_setpv(GvSV(tmpgv),PL_origargv[0]);
2685     if (PL_argvgv = gv_fetchpv("ARGV",TRUE, SVt_PVAV)) {
2686         GvMULTI_on(PL_argvgv);
2687         (void)gv_AVadd(PL_argvgv);
2688         av_clear(GvAVn(PL_argvgv));
2689         for (; argc > 0; argc--,argv++) {
2690             av_push(GvAVn(PL_argvgv),newSVpv(argv[0],0));
2691         }
2692     }
2693     if (PL_envgv = gv_fetchpv("ENV",TRUE, SVt_PVHV)) {
2694         HV *hv;
2695         GvMULTI_on(PL_envgv);
2696         hv = GvHVn(PL_envgv);
2697         hv_magic(hv, PL_envgv, 'E');
2698 #if !defined( VMS) && !defined(EPOC)  /* VMS doesn't have environ array */
2699         /* Note that if the supplied env parameter is actually a copy
2700            of the global environ then it may now point to free'd memory
2701            if the environment has been modified since. To avoid this
2702            problem we treat env==NULL as meaning 'use the default'
2703         */
2704         if (!env)
2705             env = environ;
2706         if (env != environ)
2707             environ[0] = Nullch;
2708         for (; *env; env++) {
2709             if (!(s = strchr(*env,'=')))
2710                 continue;
2711             *s++ = '\0';
2712 #if defined(MSDOS)
2713             (void)strupr(*env);
2714 #endif
2715             sv = newSVpv(s--,0);
2716             (void)hv_store(hv, *env, s - *env, sv, 0);
2717             *s = '=';
2718 #if defined(__BORLANDC__) && defined(USE_WIN32_RTL_ENV)
2719             /* Sins of the RTL. See note in my_setenv(). */
2720             (void)PerlEnv_putenv(savepv(*env));
2721 #endif
2722         }
2723 #endif
2724 #ifdef DYNAMIC_ENV_FETCH
2725         HvNAME(hv) = savepv(ENV_HV_NAME);
2726 #endif
2727     }
2728     TAINT_NOT;
2729     if (tmpgv = gv_fetchpv("$",TRUE, SVt_PV))
2730         sv_setiv(GvSV(tmpgv), (IV)getpid());
2731 }
2732
2733 STATIC void
2734 S_init_perllib(pTHX)
2735 {
2736     char *s;
2737     if (!PL_tainting) {
2738 #ifndef VMS
2739         s = PerlEnv_getenv("PERL5LIB");
2740         if (s)
2741             incpush(s, TRUE);
2742         else
2743             incpush(PerlEnv_getenv("PERLLIB"), FALSE);
2744 #else /* VMS */
2745         /* Treat PERL5?LIB as a possible search list logical name -- the
2746          * "natural" VMS idiom for a Unix path string.  We allow each
2747          * element to be a set of |-separated directories for compatibility.
2748          */
2749         char buf[256];
2750         int idx = 0;
2751         if (my_trnlnm("PERL5LIB",buf,0))
2752             do { incpush(buf,TRUE); } while (my_trnlnm("PERL5LIB",buf,++idx));
2753         else
2754             while (my_trnlnm("PERLLIB",buf,idx++)) incpush(buf,FALSE);
2755 #endif /* VMS */
2756     }
2757
2758 /* Use the ~-expanded versions of APPLLIB (undocumented),
2759     ARCHLIB PRIVLIB SITEARCH and SITELIB
2760 */
2761 #ifdef APPLLIB_EXP
2762     incpush(APPLLIB_EXP, TRUE);
2763 #endif
2764
2765 #ifdef ARCHLIB_EXP
2766     incpush(ARCHLIB_EXP, FALSE);
2767 #endif
2768 #ifndef PRIVLIB_EXP
2769 #define PRIVLIB_EXP "/usr/local/lib/perl5:/usr/local/lib/perl"
2770 #endif
2771 #if defined(WIN32)
2772     incpush(PRIVLIB_EXP, TRUE);
2773 #else
2774     incpush(PRIVLIB_EXP, FALSE);
2775 #endif
2776
2777 #ifdef SITEARCH_EXP
2778     incpush(SITEARCH_EXP, FALSE);
2779 #endif
2780 #ifdef SITELIB_EXP
2781 #if defined(WIN32)
2782     incpush(SITELIB_EXP, TRUE);
2783 #else
2784     incpush(SITELIB_EXP, FALSE);
2785 #endif
2786 #endif
2787 #if defined(PERL_VENDORLIB_EXP)
2788 #if defined(WIN32)
2789     incpush(PERL_VENDORLIB_EXP, TRUE);
2790 #else
2791     incpush(PERL_VENDORLIB_EXP, FALSE);
2792 #endif
2793 #endif
2794     if (!PL_tainting)
2795         incpush(".", FALSE);
2796 }
2797
2798 #if defined(DOSISH)
2799 #    define PERLLIB_SEP ';'
2800 #else
2801 #  if defined(VMS)
2802 #    define PERLLIB_SEP '|'
2803 #  else
2804 #    define PERLLIB_SEP ':'
2805 #  endif
2806 #endif
2807 #ifndef PERLLIB_MANGLE
2808 #  define PERLLIB_MANGLE(s,n) (s)
2809 #endif
2810
2811 STATIC void
2812 S_incpush(pTHX_ char *p, int addsubdirs)
2813 {
2814     SV *subdir = Nullsv;
2815
2816     if (!p)
2817         return;
2818
2819     if (addsubdirs) {
2820         subdir = sv_newmortal();
2821         if (!PL_archpat_auto) {
2822             STRLEN len = (sizeof(ARCHNAME) + strlen(PL_patchlevel)
2823                           + sizeof("//auto"));
2824             New(55, PL_archpat_auto, len, char);
2825             sprintf(PL_archpat_auto, "/%s/%s/auto", ARCHNAME, PL_patchlevel);
2826 #ifdef VMS
2827         for (len = sizeof(ARCHNAME) + 2;
2828              PL_archpat_auto[len] != '\0' && PL_archpat_auto[len] != '/'; len++)
2829                 if (PL_archpat_auto[len] == '.') PL_archpat_auto[len] = '_';
2830 #endif
2831         }
2832     }
2833
2834     /* Break at all separators */
2835     while (p && *p) {
2836         SV *libdir = NEWSV(55,0);
2837         char *s;
2838
2839         /* skip any consecutive separators */
2840         while ( *p == PERLLIB_SEP ) {
2841             /* Uncomment the next line for PATH semantics */
2842             /* av_push(GvAVn(PL_incgv), newSVpvn(".", 1)); */
2843             p++;
2844         }
2845
2846         if ( (s = strchr(p, PERLLIB_SEP)) != Nullch ) {
2847             sv_setpvn(libdir, PERLLIB_MANGLE(p, (STRLEN)(s - p)),
2848                       (STRLEN)(s - p));
2849             p = s + 1;
2850         }
2851         else {
2852             sv_setpv(libdir, PERLLIB_MANGLE(p, 0));
2853             p = Nullch; /* break out */
2854         }
2855
2856         /*
2857          * BEFORE pushing libdir onto @INC we may first push version- and
2858          * archname-specific sub-directories.
2859          */
2860         if (addsubdirs) {
2861             struct stat tmpstatbuf;
2862 #ifdef VMS
2863             char *unix;
2864             STRLEN len;
2865
2866             if ((unix = tounixspec_ts(SvPV(libdir,len),Nullch)) != Nullch) {
2867                 len = strlen(unix);
2868                 while (unix[len-1] == '/') len--;  /* Cosmetic */
2869                 sv_usepvn(libdir,unix,len);
2870             }
2871             else
2872                 PerlIO_printf(PerlIO_stderr(),
2873                               "Failed to unixify @INC element \"%s\"\n",
2874                               SvPV(libdir,len));
2875 #endif
2876             /* .../archname/version if -d .../archname/version/auto */
2877             sv_setsv(subdir, libdir);
2878             sv_catpv(subdir, PL_archpat_auto);
2879             if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
2880                   S_ISDIR(tmpstatbuf.st_mode))
2881                 av_push(GvAVn(PL_incgv),
2882                         newSVpvn(SvPVX(subdir), SvCUR(subdir) - sizeof "auto"));
2883
2884             /* .../archname if -d .../archname/auto */
2885             sv_insert(subdir, SvCUR(libdir) + sizeof(ARCHNAME),
2886                       strlen(PL_patchlevel) + 1, "", 0);
2887             if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
2888                   S_ISDIR(tmpstatbuf.st_mode))
2889                 av_push(GvAVn(PL_incgv),
2890                         newSVpvn(SvPVX(subdir), SvCUR(subdir) - sizeof "auto"));
2891         }
2892
2893         /* finally push this lib directory on the end of @INC */
2894         av_push(GvAVn(PL_incgv), libdir);
2895     }
2896 }
2897
2898 #ifdef USE_THREADS
2899 STATIC struct perl_thread *
2900 S_init_main_thread(pTHX)
2901 {
2902 #if !defined(PERL_IMPLICIT_CONTEXT)
2903     struct perl_thread *thr;
2904 #endif
2905     XPV *xpv;
2906
2907     Newz(53, thr, 1, struct perl_thread);
2908     PL_curcop = &PL_compiling;
2909     thr->interp = PERL_GET_INTERP;
2910     thr->cvcache = newHV();
2911     thr->threadsv = newAV();
2912     /* thr->threadsvp is set when find_threadsv is called */
2913     thr->specific = newAV();
2914     thr->errhv = newHV();
2915     thr->flags = THRf_R_JOINABLE;
2916     MUTEX_INIT(&thr->mutex);
2917     /* Handcraft thrsv similarly to mess_sv */
2918     New(53, PL_thrsv, 1, SV);
2919     Newz(53, xpv, 1, XPV);
2920     SvFLAGS(PL_thrsv) = SVt_PV;
2921     SvANY(PL_thrsv) = (void*)xpv;
2922     SvREFCNT(PL_thrsv) = 1 << 30;       /* practically infinite */
2923     SvPVX(PL_thrsv) = (char*)thr;
2924     SvCUR_set(PL_thrsv, sizeof(thr));
2925     SvLEN_set(PL_thrsv, sizeof(thr));
2926     *SvEND(PL_thrsv) = '\0';    /* in the trailing_nul field */
2927     thr->oursv = PL_thrsv;
2928     PL_chopset = " \n-";
2929     PL_dumpindent = 4;
2930
2931     MUTEX_LOCK(&PL_threads_mutex);
2932     PL_nthreads++;
2933     thr->tid = 0;
2934     thr->next = thr;
2935     thr->prev = thr;
2936     MUTEX_UNLOCK(&PL_threads_mutex);
2937
2938 #ifdef HAVE_THREAD_INTERN
2939     Perl_init_thread_intern(thr);
2940 #endif
2941
2942 #ifdef SET_THREAD_SELF
2943     SET_THREAD_SELF(thr);
2944 #else
2945     thr->self = pthread_self();
2946 #endif /* SET_THREAD_SELF */
2947     SET_THR(thr);
2948
2949     /*
2950      * These must come after the SET_THR because sv_setpvn does
2951      * SvTAINT and the taint fields require dTHR.
2952      */
2953     PL_toptarget = NEWSV(0,0);
2954     sv_upgrade(PL_toptarget, SVt_PVFM);
2955     sv_setpvn(PL_toptarget, "", 0);
2956     PL_bodytarget = NEWSV(0,0);
2957     sv_upgrade(PL_bodytarget, SVt_PVFM);
2958     sv_setpvn(PL_bodytarget, "", 0);
2959     PL_formtarget = PL_bodytarget;
2960     thr->errsv = newSVpvn("", 0);
2961     (void) find_threadsv("@");  /* Ensure $@ is initialised early */
2962
2963     PL_maxscream = -1;
2964     PL_regcompp = MEMBER_TO_FPTR(Perl_pregcomp);
2965     PL_regexecp = MEMBER_TO_FPTR(Perl_regexec_flags);
2966     PL_regint_start = MEMBER_TO_FPTR(Perl_re_intuit_start);
2967     PL_regint_string = MEMBER_TO_FPTR(Perl_re_intuit_string);
2968     PL_regfree = MEMBER_TO_FPTR(Perl_pregfree);
2969     PL_regindent = 0;
2970     PL_reginterp_cnt = 0;
2971
2972     return thr;
2973 }
2974 #endif /* USE_THREADS */
2975
2976 void
2977 Perl_call_list(pTHX_ I32 oldscope, AV *paramList)
2978 {
2979     dTHR;
2980     SV *atsv = ERRSV;
2981     line_t oldline = PL_curcop->cop_line;
2982     CV *cv;
2983     STRLEN len;
2984     int ret;
2985
2986     while (AvFILL(paramList) >= 0) {
2987         cv = (CV*)av_shift(paramList);
2988         SAVEFREESV(cv);
2989         CALLPROTECT(aTHX_ &ret, MEMBER_TO_FPTR(S_call_list_body), cv);
2990         switch (ret) {
2991         case 0:
2992             (void)SvPV(atsv, len);
2993             if (len) {
2994                 PL_curcop = &PL_compiling;
2995                 PL_curcop->cop_line = oldline;
2996                 if (paramList == PL_beginav)
2997                     sv_catpv(atsv, "BEGIN failed--compilation aborted");
2998                 else
2999                     sv_catpv(atsv, "END failed--cleanup aborted");
3000                 while (PL_scopestack_ix > oldscope)
3001                     LEAVE;
3002                 Perl_croak(aTHX_ "%s", SvPVX(atsv));
3003             }
3004             break;
3005         case 1:
3006             STATUS_ALL_FAILURE;
3007             /* FALL THROUGH */
3008         case 2:
3009             /* my_exit() was called */
3010             while (PL_scopestack_ix > oldscope)
3011                 LEAVE;
3012             FREETMPS;
3013             PL_curstash = PL_defstash;
3014             if (PL_endav)
3015                 call_list(oldscope, PL_endav);
3016             PL_curcop = &PL_compiling;
3017             PL_curcop->cop_line = oldline;
3018             if (PL_statusvalue) {
3019                 if (paramList == PL_beginav)
3020                     Perl_croak(aTHX_ "BEGIN failed--compilation aborted");
3021                 else
3022                     Perl_croak(aTHX_ "END failed--cleanup aborted");
3023             }
3024             my_exit_jump();
3025             /* NOTREACHED */
3026         case 3:
3027             if (PL_restartop) {
3028                 PL_curcop = &PL_compiling;
3029                 PL_curcop->cop_line = oldline;
3030                 JMPENV_JUMP(3);
3031             }
3032             PerlIO_printf(PerlIO_stderr(), "panic: restartop\n");
3033             FREETMPS;
3034             break;
3035         }
3036     }
3037 }
3038
3039 STATIC void *
3040 S_call_list_body(pTHX_ va_list args)
3041 {
3042     dTHR;
3043     CV *cv = va_arg(args, CV*);
3044
3045     PUSHMARK(PL_stack_sp);
3046     call_sv((SV*)cv, G_EVAL|G_DISCARD);
3047     return NULL;
3048 }
3049
3050 void
3051 Perl_my_exit(pTHX_ U32 status)
3052 {
3053     dTHR;
3054
3055     DEBUG_S(PerlIO_printf(Perl_debug_log, "my_exit: thread %p, status %lu\n",
3056                           thr, (unsigned long) status));
3057     switch (status) {
3058     case 0:
3059         STATUS_ALL_SUCCESS;
3060         break;
3061     case 1:
3062         STATUS_ALL_FAILURE;
3063         break;
3064     default:
3065         STATUS_NATIVE_SET(status);
3066         break;
3067     }
3068     my_exit_jump();
3069 }
3070
3071 void
3072 Perl_my_failure_exit(pTHX)
3073 {
3074 #ifdef VMS
3075     if (vaxc$errno & 1) {
3076         if (STATUS_NATIVE & 1)          /* fortuitiously includes "-1" */
3077             STATUS_NATIVE_SET(44);
3078     }
3079     else {
3080         if (!vaxc$errno && errno)       /* unlikely */
3081             STATUS_NATIVE_SET(44);
3082         else
3083             STATUS_NATIVE_SET(vaxc$errno);
3084     }
3085 #else
3086     int exitstatus;
3087     if (errno & 255)
3088         STATUS_POSIX_SET(errno);
3089     else {
3090         exitstatus = STATUS_POSIX >> 8;
3091         if (exitstatus & 255)
3092             STATUS_POSIX_SET(exitstatus);
3093         else
3094             STATUS_POSIX_SET(255);
3095     }
3096 #endif
3097     my_exit_jump();
3098 }
3099
3100 STATIC void
3101 S_my_exit_jump(pTHX)
3102 {
3103     dTHR;
3104     register PERL_CONTEXT *cx;
3105     I32 gimme;
3106     SV **newsp;
3107
3108     if (PL_e_script) {
3109         SvREFCNT_dec(PL_e_script);
3110         PL_e_script = Nullsv;
3111     }
3112
3113     POPSTACK_TO(PL_mainstack);
3114     if (cxstack_ix >= 0) {
3115         if (cxstack_ix > 0)
3116             dounwind(0);
3117         POPBLOCK(cx,PL_curpm);
3118         LEAVE;
3119     }
3120
3121     JMPENV_JUMP(2);
3122 }
3123
3124 #ifdef PERL_OBJECT
3125 #define NO_XSLOCKS
3126 #include "XSUB.h"
3127 #endif
3128
3129 static I32
3130 read_e_script(pTHXo_ int idx, SV *buf_sv, int maxlen)
3131 {
3132     char *p, *nl;
3133     p  = SvPVX(PL_e_script);
3134     nl = strchr(p, '\n');
3135     nl = (nl) ? nl+1 : SvEND(PL_e_script);
3136     if (nl-p == 0) {
3137         filter_del(read_e_script);
3138         return 0;
3139     }
3140     sv_catpvn(buf_sv, p, nl-p);
3141     sv_chop(PL_e_script, nl);
3142     return 1;
3143 }
3144
3145