perl.c

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