perl.c

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