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%lx\n",
1098                               (unsigned long) 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                 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_fd_on_nosuid_fs(pTHX_ int fd)
2182 {
2183     int on_nosuid  = 0;
2184     int check_okay = 0;
2185 /*
2186  * Preferred order: fstatvfs(), fstatfs(), getmntent().
2187  * fstatvfs() is UNIX98.
2188  * fstatfs() is BSD.
2189  * getmntent() is O(number-of-mounted-filesystems) and can hang.
2190  */
2191
2192 #   ifdef HAS_FSTATVFS
2193     struct statvfs stfs;
2194     check_okay = fstatvfs(fd, &stfs) == 0;
2195     on_nosuid  = check_okay && (stfs.f_flag  & ST_NOSUID);
2196 #   else
2197 #       if defined(HAS_FSTATFS) && defined(HAS_STRUCT_STATFS_FLAGS)
2198     struct statfs  stfs;
2199     check_okay = fstatfs(fd, &stfs)  == 0;
2200 #           undef PERL_MOUNT_NOSUID
2201 #           if !defined(PERL_MOUNT_NOSUID) && defined(MNT_NOSUID)
2202 #              define PERL_MOUNT_NOSUID MNT_NOSUID
2203 #           endif
2204 #           if !defined(PERL_MOUNT_NOSUID) && defined(MS_NOSUID)
2205 #              define PERL_MOUNT_NOSUID MS_NOSUID
2206 #           endif
2207 #           if !defined(PERL_MOUNT_NOSUID) && defined(M_NOSUID)
2208 #              define PERL_MOUNT_NOSUID M_NOSUID
2209 #           endif
2210 #           ifdef PERL_MOUNT_NOSUID
2211     on_nosuid  = check_okay && (stfs.f_flags & PERL_MOUNT_NOSUID);
2212 #           endif
2213 #       else
2214 #           if defined(HAS_GETMNTENT) && defined(HAS_HASMNTOPT) && defined(MNTOPT_NOSUID)
2215     FILE                *mtab = fopen("/etc/mtab", "r");
2216     struct mntent       *entry;
2217     struct stat         stb, fsb;
2218
2219     if (mtab && (fstat(fd, &stb) == 0)) {
2220         while (entry = getmntent(mtab)) {
2221             if (stat(entry->mnt_dir, &fsb) == 0
2222                 && fsb.st_dev == stb.st_dev)
2223             {
2224                 /* found the filesystem */
2225                 check_okay = 1;
2226                 if (hasmntopt(entry, MNTOPT_NOSUID))
2227                     on_nosuid = 1;
2228                 break;
2229             } /* A single fs may well fail its stat(). */
2230         }
2231     }
2232     if (mtab)
2233         fclose(mtab);
2234 #           endif /* mntent */
2235 #       endif /* statfs */
2236 #   endif /* statvfs */
2237     if (!check_okay)
2238         Perl_croak(aTHX_ "Can't check filesystem of script \"%s\"", PL_origfilename);
2239     return on_nosuid;
2240 }
2241 #endif /* IAMSUID */
2242
2243 STATIC void
2244 S_validate_suid(pTHX_ char *validarg, char *scriptname, int fdscript)
2245 {
2246     int which;
2247
2248     /* do we need to emulate setuid on scripts? */
2249
2250     /* This code is for those BSD systems that have setuid #! scripts disabled
2251      * in the kernel because of a security problem.  Merely defining DOSUID
2252      * in perl will not fix that problem, but if you have disabled setuid
2253      * scripts in the kernel, this will attempt to emulate setuid and setgid
2254      * on scripts that have those now-otherwise-useless bits set.  The setuid
2255      * root version must be called suidperl or sperlN.NNN.  If regular perl
2256      * discovers that it has opened a setuid script, it calls suidperl with
2257      * the same argv that it had.  If suidperl finds that the script it has
2258      * just opened is NOT setuid root, it sets the effective uid back to the
2259      * uid.  We don't just make perl setuid root because that loses the
2260      * effective uid we had before invoking perl, if it was different from the
2261      * uid.
2262      *
2263      * DOSUID must be defined in both perl and suidperl, and IAMSUID must
2264      * be defined in suidperl only.  suidperl must be setuid root.  The
2265      * Configure script will set this up for you if you want it.
2266      */
2267
2268 #ifdef DOSUID
2269     dTHR;
2270     char *s, *s2;
2271
2272     if (PerlLIO_fstat(PerlIO_fileno(PL_rsfp),&PL_statbuf) < 0)  /* normal stat is insecure */
2273         Perl_croak(aTHX_ "Can't stat script \"%s\"",PL_origfilename);
2274     if (fdscript < 0 && PL_statbuf.st_mode & (S_ISUID|S_ISGID)) {
2275         I32 len;
2276         STRLEN n_a;
2277
2278 #ifdef IAMSUID
2279 #ifndef HAS_SETREUID
2280         /* On this access check to make sure the directories are readable,
2281          * there is actually a small window that the user could use to make
2282          * filename point to an accessible directory.  So there is a faint
2283          * chance that someone could execute a setuid script down in a
2284          * non-accessible directory.  I don't know what to do about that.
2285          * But I don't think it's too important.  The manual lies when
2286          * it says access() is useful in setuid programs.
2287          */
2288         if (PerlLIO_access(SvPVX(GvSV(PL_curcop->cop_filegv)),1)) /*double check*/
2289             Perl_croak(aTHX_ "Permission denied");
2290 #else
2291         /* If we can swap euid and uid, then we can determine access rights
2292          * with a simple stat of the file, and then compare device and
2293          * inode to make sure we did stat() on the same file we opened.
2294          * Then we just have to make sure he or she can execute it.
2295          */
2296         {
2297             struct stat tmpstatbuf;
2298
2299             if (
2300 #ifdef HAS_SETREUID
2301                 setreuid(PL_euid,PL_uid) < 0
2302 #else
2303 # if HAS_SETRESUID
2304                 setresuid(PL_euid,PL_uid,(Uid_t)-1) < 0
2305 # endif
2306 #endif
2307                 || PerlProc_getuid() != PL_euid || PerlProc_geteuid() != PL_uid)
2308                 Perl_croak(aTHX_ "Can't swap uid and euid");    /* really paranoid */
2309             if (PerlLIO_stat(SvPVX(GvSV(PL_curcop->cop_filegv)),&tmpstatbuf) < 0)
2310                 Perl_croak(aTHX_ "Permission denied");  /* testing full pathname here */
2311 #if defined(IAMSUID) && !defined(NO_NOSUID_CHECK)
2312             if (fd_on_nosuid_fs(PerlIO_fileno(PL_rsfp)))
2313                 Perl_croak(aTHX_ "Permission denied");
2314 #endif
2315             if (tmpstatbuf.st_dev != PL_statbuf.st_dev ||
2316                 tmpstatbuf.st_ino != PL_statbuf.st_ino) {
2317                 (void)PerlIO_close(PL_rsfp);
2318                 if (PL_rsfp = PerlProc_popen("/bin/mail root","w")) {   /* heh, heh */
2319                     PerlIO_printf(PL_rsfp,
2320 "User %ld tried to run dev %ld ino %ld in place of dev %ld ino %ld!\n\
2321 (Filename of set-id script was %s, uid %ld gid %ld.)\n\nSincerely,\nperl\n",
2322                         (long)PL_uid,(long)tmpstatbuf.st_dev, (long)tmpstatbuf.st_ino,
2323                         (long)PL_statbuf.st_dev, (long)PL_statbuf.st_ino,
2324                         SvPVX(GvSV(PL_curcop->cop_filegv)),
2325                         (long)PL_statbuf.st_uid, (long)PL_statbuf.st_gid);
2326                     (void)PerlProc_pclose(PL_rsfp);
2327                 }
2328                 Perl_croak(aTHX_ "Permission denied\n");
2329             }
2330             if (
2331 #ifdef HAS_SETREUID
2332               setreuid(PL_uid,PL_euid) < 0
2333 #else
2334 # if defined(HAS_SETRESUID)
2335               setresuid(PL_uid,PL_euid,(Uid_t)-1) < 0
2336 # endif
2337 #endif
2338               || PerlProc_getuid() != PL_uid || PerlProc_geteuid() != PL_euid)
2339                 Perl_croak(aTHX_ "Can't reswap uid and euid");
2340             if (!cando(S_IXUSR,FALSE,&PL_statbuf))              /* can real uid exec? */
2341                 Perl_croak(aTHX_ "Permission denied\n");
2342         }
2343 #endif /* HAS_SETREUID */
2344 #endif /* IAMSUID */
2345
2346         if (!S_ISREG(PL_statbuf.st_mode))
2347             Perl_croak(aTHX_ "Permission denied");
2348         if (PL_statbuf.st_mode & S_IWOTH)
2349             Perl_croak(aTHX_ "Setuid/gid script is writable by world");
2350         PL_doswitches = FALSE;          /* -s is insecure in suid */
2351         PL_curcop->cop_line++;
2352         if (sv_gets(PL_linestr, PL_rsfp, 0) == Nullch ||
2353           strnNE(SvPV(PL_linestr,n_a),"#!",2) ) /* required even on Sys V */
2354             Perl_croak(aTHX_ "No #! line");
2355         s = SvPV(PL_linestr,n_a)+2;
2356         if (*s == ' ') s++;
2357         while (!isSPACE(*s)) s++;
2358         for (s2 = s;  (s2 > SvPV(PL_linestr,n_a)+2 &&
2359                        (isDIGIT(s2[-1]) || strchr("._-", s2[-1])));  s2--) ;
2360         if (strnNE(s2-4,"perl",4) && strnNE(s-9,"perl",4))  /* sanity check */
2361             Perl_croak(aTHX_ "Not a perl script");
2362         while (*s == ' ' || *s == '\t') s++;
2363         /*
2364          * #! arg must be what we saw above.  They can invoke it by
2365          * mentioning suidperl explicitly, but they may not add any strange
2366          * arguments beyond what #! says if they do invoke suidperl that way.
2367          */
2368         len = strlen(validarg);
2369         if (strEQ(validarg," PHOOEY ") ||
2370             strnNE(s,validarg,len) || !isSPACE(s[len]))
2371             Perl_croak(aTHX_ "Args must match #! line");
2372
2373 #ifndef IAMSUID
2374         if (PL_euid != PL_uid && (PL_statbuf.st_mode & S_ISUID) &&
2375             PL_euid == PL_statbuf.st_uid)
2376             if (!PL_do_undump)
2377                 Perl_croak(aTHX_ "YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
2378 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
2379 #endif /* IAMSUID */
2380
2381         if (PL_euid) {  /* oops, we're not the setuid root perl */
2382             (void)PerlIO_close(PL_rsfp);
2383 #ifndef IAMSUID
2384             /* try again */
2385             PerlProc_execv(Perl_form(aTHX_ "%s/sperl%s", BIN_EXP, PL_patchlevel), PL_origargv);
2386 #endif
2387             Perl_croak(aTHX_ "Can't do setuid\n");
2388         }
2389
2390         if (PL_statbuf.st_mode & S_ISGID && PL_statbuf.st_gid != PL_egid) {
2391 #ifdef HAS_SETEGID
2392             (void)setegid(PL_statbuf.st_gid);
2393 #else
2394 #ifdef HAS_SETREGID
2395            (void)setregid((Gid_t)-1,PL_statbuf.st_gid);
2396 #else
2397 #ifdef HAS_SETRESGID
2398            (void)setresgid((Gid_t)-1,PL_statbuf.st_gid,(Gid_t)-1);
2399 #else
2400             PerlProc_setgid(PL_statbuf.st_gid);
2401 #endif
2402 #endif
2403 #endif
2404             if (PerlProc_getegid() != PL_statbuf.st_gid)
2405                 Perl_croak(aTHX_ "Can't do setegid!\n");
2406         }
2407         if (PL_statbuf.st_mode & S_ISUID) {
2408             if (PL_statbuf.st_uid != PL_euid)
2409 #ifdef HAS_SETEUID
2410                 (void)seteuid(PL_statbuf.st_uid);       /* all that for this */
2411 #else
2412 #ifdef HAS_SETREUID
2413                 (void)setreuid((Uid_t)-1,PL_statbuf.st_uid);
2414 #else
2415 #ifdef HAS_SETRESUID
2416                 (void)setresuid((Uid_t)-1,PL_statbuf.st_uid,(Uid_t)-1);
2417 #else
2418                 PerlProc_setuid(PL_statbuf.st_uid);
2419 #endif
2420 #endif
2421 #endif
2422             if (PerlProc_geteuid() != PL_statbuf.st_uid)
2423                 Perl_croak(aTHX_ "Can't do seteuid!\n");
2424         }
2425         else if (PL_uid) {                      /* oops, mustn't run as root */
2426 #ifdef HAS_SETEUID
2427           (void)seteuid((Uid_t)PL_uid);
2428 #else
2429 #ifdef HAS_SETREUID
2430           (void)setreuid((Uid_t)-1,(Uid_t)PL_uid);
2431 #else
2432 #ifdef HAS_SETRESUID
2433           (void)setresuid((Uid_t)-1,(Uid_t)PL_uid,(Uid_t)-1);
2434 #else
2435           PerlProc_setuid((Uid_t)PL_uid);
2436 #endif
2437 #endif
2438 #endif
2439             if (PerlProc_geteuid() != PL_uid)
2440                 Perl_croak(aTHX_ "Can't do seteuid!\n");
2441         }
2442         init_ids();
2443         if (!cando(S_IXUSR,TRUE,&PL_statbuf))
2444             Perl_croak(aTHX_ "Permission denied\n");    /* they can't do this */
2445     }
2446 #ifdef IAMSUID
2447     else if (PL_preprocess)
2448         Perl_croak(aTHX_ "-P not allowed for setuid/setgid script\n");
2449     else if (fdscript >= 0)
2450         Perl_croak(aTHX_ "fd script not allowed in suidperl\n");
2451     else
2452         Perl_croak(aTHX_ "Script is not setuid/setgid in suidperl\n");
2453
2454     /* We absolutely must clear out any saved ids here, so we */
2455     /* exec the real perl, substituting fd script for scriptname. */
2456     /* (We pass script name as "subdir" of fd, which perl will grok.) */
2457     PerlIO_rewind(PL_rsfp);
2458     PerlLIO_lseek(PerlIO_fileno(PL_rsfp),(Off_t)0,0);  /* just in case rewind didn't */
2459     for (which = 1; PL_origargv[which] && PL_origargv[which] != scriptname; which++) ;
2460     if (!PL_origargv[which])
2461         Perl_croak(aTHX_ "Permission denied");
2462     PL_origargv[which] = savepv(Perl_form(aTHX_ "/dev/fd/%d/%s",
2463                                   PerlIO_fileno(PL_rsfp), PL_origargv[which]));
2464 #if defined(HAS_FCNTL) && defined(F_SETFD)
2465     fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,0);    /* ensure no close-on-exec */
2466 #endif
2467     PerlProc_execv(Perl_form(aTHX_ "%s/perl%s", BIN_EXP, PL_patchlevel), PL_origargv);/* try again */
2468     Perl_croak(aTHX_ "Can't do setuid\n");
2469 #endif /* IAMSUID */
2470 #else /* !DOSUID */
2471     if (PL_euid != PL_uid || PL_egid != PL_gid) {       /* (suidperl doesn't exist, in fact) */
2472 #ifndef SETUID_SCRIPTS_ARE_SECURE_NOW
2473         dTHR;
2474         PerlLIO_fstat(PerlIO_fileno(PL_rsfp),&PL_statbuf);      /* may be either wrapped or real suid */
2475         if ((PL_euid != PL_uid && PL_euid == PL_statbuf.st_uid && PL_statbuf.st_mode & S_ISUID)
2476             ||
2477             (PL_egid != PL_gid && PL_egid == PL_statbuf.st_gid && PL_statbuf.st_mode & S_ISGID)
2478            )
2479             if (!PL_do_undump)
2480                 Perl_croak(aTHX_ "YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
2481 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
2482 #endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
2483         /* not set-id, must be wrapped */
2484     }
2485 #endif /* DOSUID */
2486 }
2487
2488 STATIC void
2489 S_find_beginning(pTHX)
2490 {
2491     register char *s, *s2;
2492
2493     /* skip forward in input to the real script? */
2494
2495     forbid_setid("-x");
2496     while (PL_doextract) {
2497         if ((s = sv_gets(PL_linestr, PL_rsfp, 0)) == Nullch)
2498             Perl_croak(aTHX_ "No Perl script found in input\n");
2499         if (*s == '#' && s[1] == '!' && (s = instr(s,"perl"))) {
2500             PerlIO_ungetc(PL_rsfp, '\n');               /* to keep line count right */
2501             PL_doextract = FALSE;
2502             while (*s && !(isSPACE (*s) || *s == '#')) s++;
2503             s2 = s;
2504             while (*s == ' ' || *s == '\t') s++;
2505             if (*s++ == '-') {
2506                 while (isDIGIT(s2[-1]) || strchr("-._", s2[-1])) s2--;
2507                 if (strnEQ(s2-4,"perl",4))
2508                     /*SUPPRESS 530*/
2509                     while (s = moreswitches(s)) ;
2510             }
2511             if (PL_cddir && PerlDir_chdir(PL_cddir) < 0)
2512                 Perl_croak(aTHX_ "Can't chdir to %s",PL_cddir);
2513         }
2514     }
2515 }
2516
2517
2518 STATIC void
2519 S_init_ids(pTHX)
2520 {
2521     PL_uid = PerlProc_getuid();
2522     PL_euid = PerlProc_geteuid();
2523     PL_gid = PerlProc_getgid();
2524     PL_egid = PerlProc_getegid();
2525 #ifdef VMS
2526     PL_uid |= PL_gid << 16;
2527     PL_euid |= PL_egid << 16;
2528 #endif
2529     PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2530 }
2531
2532 STATIC void
2533 S_forbid_setid(pTHX_ char *s)
2534 {
2535     if (PL_euid != PL_uid)
2536         Perl_croak(aTHX_ "No %s allowed while running setuid", s);
2537     if (PL_egid != PL_gid)
2538         Perl_croak(aTHX_ "No %s allowed while running setgid", s);
2539 }
2540
2541 void
2542 Perl_init_debugger(pTHX)
2543 {
2544     dTHR;
2545     HV *ostash = PL_curstash;
2546
2547     PL_curstash = PL_debstash;
2548     PL_dbargs = GvAV(gv_AVadd((gv_fetchpv("args", GV_ADDMULTI, SVt_PVAV))));
2549     AvREAL_off(PL_dbargs);
2550     PL_DBgv = gv_fetchpv("DB", GV_ADDMULTI, SVt_PVGV);
2551     PL_DBline = gv_fetchpv("dbline", GV_ADDMULTI, SVt_PVAV);
2552     PL_DBsub = gv_HVadd(gv_fetchpv("sub", GV_ADDMULTI, SVt_PVHV));
2553     sv_upgrade(GvSV(PL_DBsub), SVt_IV); /* IVX accessed if PERLDB_SUB_NN */
2554     PL_DBsingle = GvSV((gv_fetchpv("single", GV_ADDMULTI, SVt_PV)));
2555     sv_setiv(PL_DBsingle, 0);
2556     PL_DBtrace = GvSV((gv_fetchpv("trace", GV_ADDMULTI, SVt_PV)));
2557     sv_setiv(PL_DBtrace, 0);
2558     PL_DBsignal = GvSV((gv_fetchpv("signal", GV_ADDMULTI, SVt_PV)));
2559     sv_setiv(PL_DBsignal, 0);
2560     PL_curstash = ostash;
2561 }
2562
2563 #ifndef STRESS_REALLOC
2564 #define REASONABLE(size) (size)
2565 #else
2566 #define REASONABLE(size) (1) /* unreasonable */
2567 #endif
2568
2569 void
2570 Perl_init_stacks(pTHX)
2571 {
2572     /* start with 128-item stack and 8K cxstack */
2573     PL_curstackinfo = new_stackinfo(REASONABLE(128),
2574                                  REASONABLE(8192/sizeof(PERL_CONTEXT) - 1));
2575     PL_curstackinfo->si_type = PERLSI_MAIN;
2576     PL_curstack = PL_curstackinfo->si_stack;
2577     PL_mainstack = PL_curstack;         /* remember in case we switch stacks */
2578
2579     PL_stack_base = AvARRAY(PL_curstack);
2580     PL_stack_sp = PL_stack_base;
2581     PL_stack_max = PL_stack_base + AvMAX(PL_curstack);
2582
2583     New(50,PL_tmps_stack,REASONABLE(128),SV*);
2584     PL_tmps_floor = -1;
2585     PL_tmps_ix = -1;
2586     PL_tmps_max = REASONABLE(128);
2587
2588     New(54,PL_markstack,REASONABLE(32),I32);
2589     PL_markstack_ptr = PL_markstack;
2590     PL_markstack_max = PL_markstack + REASONABLE(32);
2591
2592     SET_MARKBASE;
2593
2594     New(54,PL_scopestack,REASONABLE(32),I32);
2595     PL_scopestack_ix = 0;
2596     PL_scopestack_max = REASONABLE(32);
2597
2598     New(54,PL_savestack,REASONABLE(128),ANY);
2599     PL_savestack_ix = 0;
2600     PL_savestack_max = REASONABLE(128);
2601
2602     New(54,PL_retstack,REASONABLE(16),OP*);
2603     PL_retstack_ix = 0;
2604     PL_retstack_max = REASONABLE(16);
2605 }
2606
2607 #undef REASONABLE
2608
2609 STATIC void
2610 S_nuke_stacks(pTHX)
2611 {
2612     dTHR;
2613     while (PL_curstackinfo->si_next)
2614         PL_curstackinfo = PL_curstackinfo->si_next;
2615     while (PL_curstackinfo) {
2616         PERL_SI *p = PL_curstackinfo->si_prev;
2617         /* curstackinfo->si_stack got nuked by sv_free_arenas() */
2618         Safefree(PL_curstackinfo->si_cxstack);
2619         Safefree(PL_curstackinfo);
2620         PL_curstackinfo = p;
2621     }
2622     Safefree(PL_tmps_stack);
2623     Safefree(PL_markstack);
2624     Safefree(PL_scopestack);
2625     Safefree(PL_savestack);
2626     Safefree(PL_retstack);
2627     DEBUG( {
2628         Safefree(PL_debname);
2629         Safefree(PL_debdelim);
2630     } )
2631 }
2632
2633 #ifndef PERL_OBJECT
2634 static PerlIO *tmpfp;  /* moved outside init_lexer() because of UNICOS bug */
2635 #endif
2636
2637 STATIC void
2638 S_init_lexer(pTHX)
2639 {
2640 #ifdef PERL_OBJECT
2641         PerlIO *tmpfp;
2642 #endif
2643     tmpfp = PL_rsfp;
2644     PL_rsfp = Nullfp;
2645     lex_start(PL_linestr);
2646     PL_rsfp = tmpfp;
2647     PL_subname = newSVpvn("main",4);
2648 }
2649
2650 STATIC void
2651 S_init_predump_symbols(pTHX)
2652 {
2653     dTHR;
2654     GV *tmpgv;
2655     GV *othergv;
2656     IO *io;
2657
2658     sv_setpvn(get_sv("\"", TRUE), " ", 1);
2659     PL_stdingv = gv_fetchpv("STDIN",TRUE, SVt_PVIO);
2660     GvMULTI_on(PL_stdingv);
2661     io = GvIOp(PL_stdingv);
2662     IoIFP(io) = PerlIO_stdin();
2663     tmpgv = gv_fetchpv("stdin",TRUE, SVt_PV);
2664     GvMULTI_on(tmpgv);
2665     GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io);
2666
2667     tmpgv = gv_fetchpv("STDOUT",TRUE, SVt_PVIO);
2668     GvMULTI_on(tmpgv);
2669     io = GvIOp(tmpgv);
2670     IoOFP(io) = IoIFP(io) = PerlIO_stdout();
2671     setdefout(tmpgv);
2672     tmpgv = gv_fetchpv("stdout",TRUE, SVt_PV);
2673     GvMULTI_on(tmpgv);
2674     GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io);
2675
2676     PL_stderrgv = gv_fetchpv("STDERR",TRUE, SVt_PVIO);
2677     GvMULTI_on(PL_stderrgv);
2678     io = GvIOp(PL_stderrgv);
2679     IoOFP(io) = IoIFP(io) = PerlIO_stderr();
2680     tmpgv = gv_fetchpv("stderr",TRUE, SVt_PV);
2681     GvMULTI_on(tmpgv);
2682     GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io);
2683
2684     PL_statname = NEWSV(66,0);          /* last filename we did stat on */
2685
2686     if (!PL_osname)
2687         PL_osname = savepv(OSNAME);
2688 }
2689
2690 STATIC void
2691 S_init_postdump_symbols(pTHX_ register int argc, register char **argv, register char **env)
2692 {
2693     dTHR;
2694     char *s;
2695     SV *sv;
2696     GV* tmpgv;
2697
2698     argc--,argv++;      /* skip name of script */
2699     if (PL_doswitches) {
2700         for (; argc > 0 && **argv == '-'; argc--,argv++) {
2701             if (!argv[0][1])
2702                 break;
2703             if (argv[0][1] == '-') {
2704                 argc--,argv++;
2705                 break;
2706             }
2707             if (s = strchr(argv[0], '=')) {
2708                 *s++ = '\0';
2709                 sv_setpv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),s);
2710             }
2711             else
2712                 sv_setiv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),1);
2713         }
2714     }
2715     PL_toptarget = NEWSV(0,0);
2716     sv_upgrade(PL_toptarget, SVt_PVFM);
2717     sv_setpvn(PL_toptarget, "", 0);
2718     PL_bodytarget = NEWSV(0,0);
2719     sv_upgrade(PL_bodytarget, SVt_PVFM);
2720     sv_setpvn(PL_bodytarget, "", 0);
2721     PL_formtarget = PL_bodytarget;
2722
2723     TAINT;
2724     if (tmpgv = gv_fetchpv("0",TRUE, SVt_PV)) {
2725         sv_setpv(GvSV(tmpgv),PL_origfilename);
2726         magicname("0", "0", 1);
2727     }
2728     if (tmpgv = gv_fetchpv("\030",TRUE, SVt_PV))
2729         sv_setpv(GvSV(tmpgv),PL_origargv[0]);
2730     if (PL_argvgv = gv_fetchpv("ARGV",TRUE, SVt_PVAV)) {
2731         GvMULTI_on(PL_argvgv);
2732         (void)gv_AVadd(PL_argvgv);
2733         av_clear(GvAVn(PL_argvgv));
2734         for (; argc > 0; argc--,argv++) {
2735             av_push(GvAVn(PL_argvgv),newSVpv(argv[0],0));
2736         }
2737     }
2738     if (PL_envgv = gv_fetchpv("ENV",TRUE, SVt_PVHV)) {
2739         HV *hv;
2740         GvMULTI_on(PL_envgv);
2741         hv = GvHVn(PL_envgv);
2742         hv_magic(hv, PL_envgv, 'E');
2743 #if !defined( VMS) && !defined(EPOC)  /* VMS doesn't have environ array */
2744         /* Note that if the supplied env parameter is actually a copy
2745            of the global environ then it may now point to free'd memory
2746            if the environment has been modified since. To avoid this
2747            problem we treat env==NULL as meaning 'use the default'
2748         */
2749         if (!env)
2750             env = environ;
2751         if (env != environ)
2752             environ[0] = Nullch;
2753         for (; *env; env++) {
2754             if (!(s = strchr(*env,'=')))
2755                 continue;
2756             *s++ = '\0';
2757 #if defined(MSDOS)
2758             (void)strupr(*env);
2759 #endif
2760             sv = newSVpv(s--,0);
2761             (void)hv_store(hv, *env, s - *env, sv, 0);
2762             *s = '=';
2763 #if defined(__BORLANDC__) && defined(USE_WIN32_RTL_ENV)
2764             /* Sins of the RTL. See note in my_setenv(). */
2765             (void)PerlEnv_putenv(savepv(*env));
2766 #endif
2767         }
2768 #endif
2769 #ifdef DYNAMIC_ENV_FETCH
2770         HvNAME(hv) = savepv(ENV_HV_NAME);
2771 #endif
2772     }
2773     TAINT_NOT;
2774     if (tmpgv = gv_fetchpv("$",TRUE, SVt_PV))
2775         sv_setiv(GvSV(tmpgv), (IV)getpid());
2776 }
2777
2778 STATIC void
2779 S_init_perllib(pTHX)
2780 {
2781     char *s;
2782     if (!PL_tainting) {
2783 #ifndef VMS
2784         s = PerlEnv_getenv("PERL5LIB");
2785         if (s)
2786             incpush(s, TRUE);
2787         else
2788             incpush(PerlEnv_getenv("PERLLIB"), FALSE);
2789 #else /* VMS */
2790         /* Treat PERL5?LIB as a possible search list logical name -- the
2791          * "natural" VMS idiom for a Unix path string.  We allow each
2792          * element to be a set of |-separated directories for compatibility.
2793          */
2794         char buf[256];
2795         int idx = 0;
2796         if (my_trnlnm("PERL5LIB",buf,0))
2797             do { incpush(buf,TRUE); } while (my_trnlnm("PERL5LIB",buf,++idx));
2798         else
2799             while (my_trnlnm("PERLLIB",buf,idx++)) incpush(buf,FALSE);
2800 #endif /* VMS */
2801     }
2802
2803 /* Use the ~-expanded versions of APPLLIB (undocumented),
2804     ARCHLIB PRIVLIB SITEARCH and SITELIB
2805 */
2806 #ifdef APPLLIB_EXP
2807     incpush(APPLLIB_EXP, TRUE);
2808 #endif
2809
2810 #ifdef ARCHLIB_EXP
2811     incpush(ARCHLIB_EXP, FALSE);
2812 #endif
2813 #ifndef PRIVLIB_EXP
2814 #define PRIVLIB_EXP "/usr/local/lib/perl5:/usr/local/lib/perl"
2815 #endif
2816 #if defined(WIN32)
2817     incpush(PRIVLIB_EXP, TRUE);
2818 #else
2819     incpush(PRIVLIB_EXP, FALSE);
2820 #endif
2821
2822 #ifdef SITEARCH_EXP
2823     incpush(SITEARCH_EXP, FALSE);
2824 #endif
2825 #ifdef SITELIB_EXP
2826 #if defined(WIN32)
2827     incpush(SITELIB_EXP, TRUE);
2828 #else
2829     incpush(SITELIB_EXP, FALSE);
2830 #endif
2831 #endif
2832 #if defined(PERL_VENDORLIB_EXP)
2833 #if defined(WIN32)
2834     incpush(PERL_VENDORLIB_EXP, TRUE);
2835 #else
2836     incpush(PERL_VENDORLIB_EXP, FALSE);
2837 #endif
2838 #endif
2839     if (!PL_tainting)
2840         incpush(".", FALSE);
2841 }
2842
2843 #if defined(DOSISH)
2844 #    define PERLLIB_SEP ';'
2845 #else
2846 #  if defined(VMS)
2847 #    define PERLLIB_SEP '|'
2848 #  else
2849 #    define PERLLIB_SEP ':'
2850 #  endif
2851 #endif
2852 #ifndef PERLLIB_MANGLE
2853 #  define PERLLIB_MANGLE(s,n) (s)
2854 #endif
2855
2856 STATIC void
2857 S_incpush(pTHX_ char *p, int addsubdirs)
2858 {
2859     SV *subdir = Nullsv;
2860
2861     if (!p)
2862         return;
2863
2864     if (addsubdirs) {
2865         subdir = sv_newmortal();
2866         if (!PL_archpat_auto) {
2867             STRLEN len = (sizeof(ARCHNAME) + strlen(PL_patchlevel)
2868                           + sizeof("//auto"));
2869             New(55, PL_archpat_auto, len, char);
2870             sprintf(PL_archpat_auto, "/%s/%s/auto", ARCHNAME, PL_patchlevel);
2871 #ifdef VMS
2872         for (len = sizeof(ARCHNAME) + 2;
2873              PL_archpat_auto[len] != '\0' && PL_archpat_auto[len] != '/'; len++)
2874                 if (PL_archpat_auto[len] == '.') PL_archpat_auto[len] = '_';
2875 #endif
2876         }
2877     }
2878
2879     /* Break at all separators */
2880     while (p && *p) {
2881         SV *libdir = NEWSV(55,0);
2882         char *s;
2883
2884         /* skip any consecutive separators */
2885         while ( *p == PERLLIB_SEP ) {
2886             /* Uncomment the next line for PATH semantics */
2887             /* av_push(GvAVn(PL_incgv), newSVpvn(".", 1)); */
2888             p++;
2889         }
2890
2891         if ( (s = strchr(p, PERLLIB_SEP)) != Nullch ) {
2892             sv_setpvn(libdir, PERLLIB_MANGLE(p, (STRLEN)(s - p)),
2893                       (STRLEN)(s - p));
2894             p = s + 1;
2895         }
2896         else {
2897             sv_setpv(libdir, PERLLIB_MANGLE(p, 0));
2898             p = Nullch; /* break out */
2899         }
2900
2901         /*
2902          * BEFORE pushing libdir onto @INC we may first push version- and
2903          * archname-specific sub-directories.
2904          */
2905         if (addsubdirs) {
2906             struct stat tmpstatbuf;
2907 #ifdef VMS
2908             char *unix;
2909             STRLEN len;
2910
2911             if ((unix = tounixspec_ts(SvPV(libdir,len),Nullch)) != Nullch) {
2912                 len = strlen(unix);
2913                 while (unix[len-1] == '/') len--;  /* Cosmetic */
2914                 sv_usepvn(libdir,unix,len);
2915             }
2916             else
2917                 PerlIO_printf(Perl_error_log,
2918                               "Failed to unixify @INC element \"%s\"\n",
2919                               SvPV(libdir,len));
2920 #endif
2921             /* .../archname/version if -d .../archname/version/auto */
2922             sv_setsv(subdir, libdir);
2923             sv_catpv(subdir, PL_archpat_auto);
2924             if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
2925                   S_ISDIR(tmpstatbuf.st_mode))
2926                 av_push(GvAVn(PL_incgv),
2927                         newSVpvn(SvPVX(subdir), SvCUR(subdir) - sizeof "auto"));
2928
2929             /* .../archname if -d .../archname/auto */
2930             sv_insert(subdir, SvCUR(libdir) + sizeof(ARCHNAME),
2931                       strlen(PL_patchlevel) + 1, "", 0);
2932             if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
2933                   S_ISDIR(tmpstatbuf.st_mode))
2934                 av_push(GvAVn(PL_incgv),
2935                         newSVpvn(SvPVX(subdir), SvCUR(subdir) - sizeof "auto"));
2936         }
2937
2938         /* finally push this lib directory on the end of @INC */
2939         av_push(GvAVn(PL_incgv), libdir);
2940     }
2941 }
2942
2943 #ifdef USE_THREADS
2944 STATIC struct perl_thread *
2945 S_init_main_thread(pTHX)
2946 {
2947 #if !defined(PERL_IMPLICIT_CONTEXT)
2948     struct perl_thread *thr;
2949 #endif
2950     XPV *xpv;
2951
2952     Newz(53, thr, 1, struct perl_thread);
2953     PL_curcop = &PL_compiling;
2954     thr->interp = PERL_GET_INTERP;
2955     thr->cvcache = newHV();
2956     thr->threadsv = newAV();
2957     /* thr->threadsvp is set when find_threadsv is called */
2958     thr->specific = newAV();
2959     thr->flags = THRf_R_JOINABLE;
2960     MUTEX_INIT(&thr->mutex);
2961     /* Handcraft thrsv similarly to mess_sv */
2962     New(53, PL_thrsv, 1, SV);
2963     Newz(53, xpv, 1, XPV);
2964     SvFLAGS(PL_thrsv) = SVt_PV;
2965     SvANY(PL_thrsv) = (void*)xpv;
2966     SvREFCNT(PL_thrsv) = 1 << 30;       /* practically infinite */
2967     SvPVX(PL_thrsv) = (char*)thr;
2968     SvCUR_set(PL_thrsv, sizeof(thr));
2969     SvLEN_set(PL_thrsv, sizeof(thr));
2970     *SvEND(PL_thrsv) = '\0';    /* in the trailing_nul field */
2971     thr->oursv = PL_thrsv;
2972     PL_chopset = " \n-";
2973     PL_dumpindent = 4;
2974
2975     MUTEX_LOCK(&PL_threads_mutex);
2976     PL_nthreads++;
2977     thr->tid = 0;
2978     thr->next = thr;
2979     thr->prev = thr;
2980     MUTEX_UNLOCK(&PL_threads_mutex);
2981
2982 #ifdef HAVE_THREAD_INTERN
2983     Perl_init_thread_intern(thr);
2984 #endif
2985
2986 #ifdef SET_THREAD_SELF
2987     SET_THREAD_SELF(thr);
2988 #else
2989     thr->self = pthread_self();
2990 #endif /* SET_THREAD_SELF */
2991     SET_THR(thr);
2992
2993     /*
2994      * These must come after the SET_THR because sv_setpvn does
2995      * SvTAINT and the taint fields require dTHR.
2996      */
2997     PL_toptarget = NEWSV(0,0);
2998     sv_upgrade(PL_toptarget, SVt_PVFM);
2999     sv_setpvn(PL_toptarget, "", 0);
3000     PL_bodytarget = NEWSV(0,0);
3001     sv_upgrade(PL_bodytarget, SVt_PVFM);
3002     sv_setpvn(PL_bodytarget, "", 0);
3003     PL_formtarget = PL_bodytarget;
3004     thr->errsv = newSVpvn("", 0);
3005     (void) find_threadsv("@");  /* Ensure $@ is initialised early */
3006
3007     PL_maxscream = -1;
3008     PL_regcompp = MEMBER_TO_FPTR(Perl_pregcomp);
3009     PL_regexecp = MEMBER_TO_FPTR(Perl_regexec_flags);
3010     PL_regint_start = MEMBER_TO_FPTR(Perl_re_intuit_start);
3011     PL_regint_string = MEMBER_TO_FPTR(Perl_re_intuit_string);
3012     PL_regfree = MEMBER_TO_FPTR(Perl_pregfree);
3013     PL_regindent = 0;
3014     PL_reginterp_cnt = 0;
3015
3016     return thr;
3017 }
3018 #endif /* USE_THREADS */
3019
3020 void
3021 Perl_call_list(pTHX_ I32 oldscope, AV *paramList)
3022 {
3023     dTHR;
3024     SV *atsv = ERRSV;
3025     line_t oldline = PL_curcop->cop_line;
3026     CV *cv;
3027     STRLEN len;
3028     int ret;
3029     dJMPENV;
3030
3031     while (AvFILL(paramList) >= 0) {
3032         cv = (CV*)av_shift(paramList);
3033         SAVEFREESV(cv);
3034         CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_call_list_body), cv);
3035         switch (ret) {
3036         case 0:
3037             (void)SvPV(atsv, len);
3038             if (len) {
3039                 PL_curcop = &PL_compiling;
3040                 PL_curcop->cop_line = oldline;
3041                 if (paramList == PL_beginav)
3042                     sv_catpv(atsv, "BEGIN failed--compilation aborted");
3043                 else
3044                     sv_catpv(atsv, "END failed--cleanup aborted");
3045                 while (PL_scopestack_ix > oldscope)
3046                     LEAVE;
3047                 Perl_croak(aTHX_ "%s", SvPVX(atsv));
3048             }
3049             break;
3050         case 1:
3051             STATUS_ALL_FAILURE;
3052             /* FALL THROUGH */
3053         case 2:
3054             /* my_exit() was called */
3055             while (PL_scopestack_ix > oldscope)
3056                 LEAVE;
3057             FREETMPS;
3058             PL_curstash = PL_defstash;
3059             if (PL_endav && !PL_minus_c)
3060                 call_list(oldscope, PL_endav);
3061             PL_curcop = &PL_compiling;
3062             PL_curcop->cop_line = oldline;
3063             if (PL_statusvalue) {
3064                 if (paramList == PL_beginav)
3065                     Perl_croak(aTHX_ "BEGIN failed--compilation aborted");
3066                 else
3067                     Perl_croak(aTHX_ "END failed--cleanup aborted");
3068             }
3069             my_exit_jump();
3070             /* NOTREACHED */
3071         case 3:
3072             if (PL_restartop) {
3073                 PL_curcop = &PL_compiling;
3074                 PL_curcop->cop_line = oldline;
3075                 JMPENV_JUMP(3);
3076             }
3077             PerlIO_printf(Perl_error_log, "panic: restartop\n");
3078             FREETMPS;
3079             break;
3080         }
3081     }
3082 }
3083
3084 STATIC void *
3085 S_call_list_body(pTHX_ va_list args)
3086 {
3087     dTHR;
3088     CV *cv = va_arg(args, CV*);
3089
3090     PUSHMARK(PL_stack_sp);
3091     call_sv((SV*)cv, G_EVAL|G_DISCARD);
3092     return NULL;
3093 }
3094
3095 void
3096 Perl_my_exit(pTHX_ U32 status)
3097 {
3098     dTHR;
3099
3100     DEBUG_S(PerlIO_printf(Perl_debug_log, "my_exit: thread %p, status %lu\n",
3101                           thr, (unsigned long) status));
3102     switch (status) {
3103     case 0:
3104         STATUS_ALL_SUCCESS;
3105         break;
3106     case 1:
3107         STATUS_ALL_FAILURE;
3108         break;
3109     default:
3110         STATUS_NATIVE_SET(status);
3111         break;
3112     }
3113     my_exit_jump();
3114 }
3115
3116 void
3117 Perl_my_failure_exit(pTHX)
3118 {
3119 #ifdef VMS
3120     if (vaxc$errno & 1) {
3121         if (STATUS_NATIVE & 1)          /* fortuitiously includes "-1" */
3122             STATUS_NATIVE_SET(44);
3123     }
3124     else {
3125         if (!vaxc$errno && errno)       /* unlikely */
3126             STATUS_NATIVE_SET(44);
3127         else
3128             STATUS_NATIVE_SET(vaxc$errno);
3129     }
3130 #else
3131     int exitstatus;
3132     if (errno & 255)
3133         STATUS_POSIX_SET(errno);
3134     else {
3135         exitstatus = STATUS_POSIX >> 8;
3136         if (exitstatus & 255)
3137             STATUS_POSIX_SET(exitstatus);
3138         else
3139             STATUS_POSIX_SET(255);
3140     }
3141 #endif
3142     my_exit_jump();
3143 }
3144
3145 STATIC void
3146 S_my_exit_jump(pTHX)
3147 {
3148     dTHR;
3149     register PERL_CONTEXT *cx;
3150     I32 gimme;
3151     SV **newsp;
3152
3153     if (PL_e_script) {
3154         SvREFCNT_dec(PL_e_script);
3155         PL_e_script = Nullsv;
3156     }
3157
3158     POPSTACK_TO(PL_mainstack);
3159     if (cxstack_ix >= 0) {
3160         if (cxstack_ix > 0)
3161             dounwind(0);
3162         POPBLOCK(cx,PL_curpm);
3163         LEAVE;
3164     }
3165
3166     JMPENV_JUMP(2);
3167 }
3168
3169 #ifdef PERL_OBJECT
3170 #define NO_XSLOCKS
3171 #include "XSUB.h"
3172 #endif
3173
3174 static I32
3175 read_e_script(pTHXo_ int idx, SV *buf_sv, int maxlen)
3176 {
3177     char *p, *nl;
3178     p  = SvPVX(PL_e_script);
3179     nl = strchr(p, '\n');
3180     nl = (nl) ? nl+1 : SvEND(PL_e_script);
3181     if (nl-p == 0) {
3182         filter_del(read_e_script);
3183         return 0;
3184     }
3185     sv_catpvn(buf_sv, p, nl-p);
3186     sv_chop(PL_e_script, nl);
3187     return 1;
3188 }
3189
3190