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