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