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