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