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