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