perl.c

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