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