perl.c

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