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