perl.c

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