perl.c

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