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