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         croak(SvPVx(ERRSV, PL_na));
1453
1454     return sv;
1455 }
1456
1457 /* Require a module. */
1458
1459 void
1460 perl_require_pv(char *pv)
1461 {
1462     SV* sv;
1463     dSP;
1464     PUSHSTACKi(PERLSI_REQUIRE);
1465     PUTBACK;
1466     sv = sv_newmortal();
1467     sv_setpv(sv, "require '");
1468     sv_catpv(sv, pv);
1469     sv_catpv(sv, "'");
1470     perl_eval_sv(sv, G_DISCARD);
1471     SPAGAIN;
1472     POPSTACK;
1473 }
1474
1475 void
1476 magicname(char *sym, char *name, I32 namlen)
1477 {
1478     register GV *gv;
1479
1480     if (gv = gv_fetchpv(sym,TRUE, SVt_PV))
1481         sv_magic(GvSV(gv), (SV*)gv, 0, name, namlen);
1482 }
1483
1484 STATIC void
1485 usage(char *name)               /* XXX move this out into a module ? */
1486
1487 {
1488     /* This message really ought to be max 23 lines.
1489      * Removed -h because the user already knows that opton. Others? */
1490
1491     static char *usage_msg[] = {
1492 "-0[octal]       specify record separator (\\0, if no argument)",
1493 "-a              autosplit mode with -n or -p (splits $_ into @F)",
1494 "-c              check syntax only (runs BEGIN and END blocks)",
1495 "-d[:debugger]   run scripts under debugger",
1496 "-D[number/list] set debugging flags (argument is a bit mask or flags)",
1497 "-e 'command'    one line of script. Several -e's allowed. Omit [programfile].",
1498 "-F/pattern/     split() pattern for autosplit (-a). The //'s are optional.",
1499 "-i[extension]   edit <> files in place (make backup if extension supplied)",
1500 "-Idirectory     specify @INC/#include directory (may be used more than once)",
1501 "-l[octal]       enable line ending processing, specifies line terminator",
1502 "-[mM][-]module.. executes `use/no module...' before executing your script.",
1503 "-n              assume 'while (<>) { ... }' loop around your script",
1504 "-p              assume loop like -n but print line also like sed",
1505 "-P              run script through C preprocessor before compilation",
1506 "-s              enable some switch parsing for switches after script name",
1507 "-S              look for the script using PATH environment variable",
1508 "-T              turn on tainting checks",
1509 "-u              dump core after parsing script",
1510 "-U              allow unsafe operations",
1511 "-v              print version number, patchlevel plus VERY IMPORTANT perl info",
1512 "-V[:variable]   print perl configuration information",
1513 "-w              TURN WARNINGS ON FOR COMPILATION OF YOUR SCRIPT. Recommended.",
1514 "-x[directory]   strip off text before #!perl line and perhaps cd to directory",
1515 "\n",
1516 NULL
1517 };
1518     char **p = usage_msg;
1519
1520     printf("\nUsage: %s [switches] [--] [programfile] [arguments]", name);
1521     while (*p)
1522         printf("\n  %s", *p++);
1523 }
1524
1525 /* This routine handles any switches that can be given during run */
1526
1527 char *
1528 moreswitches(char *s)
1529 {
1530     I32 numlen;
1531     U32 rschar;
1532
1533     switch (*s) {
1534     case '0':
1535     {
1536         dTHR;
1537         rschar = scan_oct(s, 4, &numlen);
1538         SvREFCNT_dec(PL_nrs);
1539         if (rschar & ~((U8)~0))
1540             PL_nrs = &PL_sv_undef;
1541         else if (!rschar && numlen >= 2)
1542             PL_nrs = newSVpv("", 0);
1543         else {
1544             char ch = rschar;
1545             PL_nrs = newSVpv(&ch, 1);
1546         }
1547         return s + numlen;
1548     }
1549     case 'F':
1550         PL_minus_F = TRUE;
1551         PL_splitstr = savepv(s + 1);
1552         s += strlen(s);
1553         return s;
1554     case 'a':
1555         PL_minus_a = TRUE;
1556         s++;
1557         return s;
1558     case 'c':
1559         PL_minus_c = TRUE;
1560         s++;
1561         return s;
1562     case 'd':
1563         forbid_setid("-d");
1564         s++;
1565         if (*s == ':' || *s == '=')  {
1566             my_setenv("PERL5DB", form("use Devel::%s;", ++s));
1567             s += strlen(s);
1568         }
1569         if (!PL_perldb) {
1570             PL_perldb = PERLDB_ALL;
1571             init_debugger();
1572         }
1573         return s;
1574     case 'D':
1575 #ifdef DEBUGGING
1576         forbid_setid("-D");
1577         if (isALPHA(s[1])) {
1578             static char debopts[] = "psltocPmfrxuLHXDS";
1579             char *d;
1580
1581             for (s++; *s && (d = strchr(debopts,*s)); s++)
1582                 PL_debug |= 1 << (d - debopts);
1583         }
1584         else {
1585             PL_debug = atoi(s+1);
1586             for (s++; isDIGIT(*s); s++) ;
1587         }
1588         PL_debug |= 0x80000000;
1589 #else
1590         warn("Recompile perl with -DDEBUGGING to use -D switch\n");
1591         for (s++; isALNUM(*s); s++) ;
1592 #endif
1593         /*SUPPRESS 530*/
1594         return s;
1595     case 'h':
1596         usage(PL_origargv[0]);
1597         PerlProc_exit(0);
1598     case 'i':
1599         if (PL_inplace)
1600             Safefree(PL_inplace);
1601         PL_inplace = savepv(s+1);
1602         /*SUPPRESS 530*/
1603         for (s = PL_inplace; *s && !isSPACE(*s); s++) ;
1604         if (*s) {
1605             *s++ = '\0';
1606             if (*s == '-')      /* Additional switches on #! line. */
1607                 s++;
1608         }
1609         return s;
1610     case 'I':   /* -I handled both here and in parse_perl() */
1611         forbid_setid("-I");
1612         ++s;
1613         while (*s && isSPACE(*s))
1614             ++s;
1615         if (*s) {
1616             char *e, *p;
1617             for (e = s; *e && !isSPACE(*e); e++) ;
1618             p = savepvn(s, e-s);
1619             incpush(p, TRUE);
1620             Safefree(p);
1621             s = e;
1622         }
1623         else
1624             croak("No space allowed after -I");
1625         return s;
1626     case 'l':
1627         PL_minus_l = TRUE;
1628         s++;
1629         if (PL_ors)
1630             Safefree(PL_ors);
1631         if (isDIGIT(*s)) {
1632             PL_ors = savepv("\n");
1633             PL_orslen = 1;
1634             *PL_ors = scan_oct(s, 3 + (*s == '0'), &numlen);
1635             s += numlen;
1636         }
1637         else {
1638             dTHR;
1639             if (RsPARA(PL_nrs)) {
1640                 PL_ors = "\n\n";
1641                 PL_orslen = 2;
1642             }
1643             else
1644                 PL_ors = SvPV(PL_nrs, PL_orslen);
1645             PL_ors = savepvn(PL_ors, PL_orslen);
1646         }
1647         return s;
1648     case 'M':
1649         forbid_setid("-M");     /* XXX ? */
1650         /* FALL THROUGH */
1651     case 'm':
1652         forbid_setid("-m");     /* XXX ? */
1653         if (*++s) {
1654             char *start;
1655             SV *sv;
1656             char *use = "use ";
1657             /* -M-foo == 'no foo'       */
1658             if (*s == '-') { use = "no "; ++s; }
1659             sv = newSVpv(use,0);
1660             start = s;
1661             /* We allow -M'Module qw(Foo Bar)'  */
1662             while(isALNUM(*s) || *s==':') ++s;
1663             if (*s != '=') {
1664                 sv_catpv(sv, start);
1665                 if (*(start-1) == 'm') {
1666                     if (*s != '\0')
1667                         croak("Can't use '%c' after -mname", *s);
1668                     sv_catpv( sv, " ()");
1669                 }
1670             } else {
1671                 sv_catpvn(sv, start, s-start);
1672                 sv_catpv(sv, " split(/,/,q{");
1673                 sv_catpv(sv, ++s);
1674                 sv_catpv(sv,    "})");
1675             }
1676             s += strlen(s);
1677             if (PL_preambleav == NULL)
1678                 PL_preambleav = newAV();
1679             av_push(PL_preambleav, sv);
1680         }
1681         else
1682             croak("No space allowed after -%c", *(s-1));
1683         return s;
1684     case 'n':
1685         PL_minus_n = TRUE;
1686         s++;
1687         return s;
1688     case 'p':
1689         PL_minus_p = TRUE;
1690         s++;
1691         return s;
1692     case 's':
1693         forbid_setid("-s");
1694         PL_doswitches = TRUE;
1695         s++;
1696         return s;
1697     case 'T':
1698         if (!PL_tainting)
1699             croak("Too late for \"-T\" option");
1700         s++;
1701         return s;
1702     case 'u':
1703         PL_do_undump = TRUE;
1704         s++;
1705         return s;
1706     case 'U':
1707         PL_unsafe = TRUE;
1708         s++;
1709         return s;
1710     case 'v':
1711 #if defined(SUBVERSION) && SUBVERSION > 0
1712         printf("\nThis is perl, version 5.%03d_%02d built for %s",
1713             PATCHLEVEL, SUBVERSION, ARCHNAME);
1714 #else
1715         printf("\nThis is perl, version %s built for %s",
1716                 PL_patchlevel, ARCHNAME);
1717 #endif
1718 #if defined(LOCAL_PATCH_COUNT)
1719         if (LOCAL_PATCH_COUNT > 0)
1720             printf("\n(with %d registered patch%s, see perl -V for more detail)",
1721                 LOCAL_PATCH_COUNT, (LOCAL_PATCH_COUNT!=1) ? "es" : "");
1722 #endif
1723
1724         printf("\n\nCopyright 1987-1998, Larry Wall\n");
1725 #ifdef MSDOS
1726         printf("\nMS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n");
1727 #endif
1728 #ifdef DJGPP
1729         printf("djgpp v2 port (jpl5003c) by Hirofumi Watanabe, 1996\n");
1730         printf("djgpp v2 port (perl5004+) by Laszlo Molnar, 1997-1998\n");
1731 #endif
1732 #ifdef OS2
1733         printf("\n\nOS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n"
1734             "Version 5 port Copyright (c) 1994-1998, Andreas Kaiser, Ilya Zakharevich\n");
1735 #endif
1736 #ifdef atarist
1737         printf("atariST series port, ++jrb  bammi@cadence.com\n");
1738 #endif
1739 #ifdef __BEOS__
1740         printf("BeOS port Copyright Tom Spindler, 1997-1998\n");
1741 #endif
1742 #ifdef MPE
1743         printf("MPE/iX port Copyright by Mark Klein and Mark Bixby, 1996-1998\n");
1744 #endif
1745 #ifdef OEMVS
1746         printf("MVS (OS390) port by Mortice Kern Systems, 1997-1998\n");
1747 #endif
1748 #ifdef __VOS__
1749         printf("Stratus VOS port by Paul_Green@stratus.com, 1997-1998\n");
1750 #endif
1751 #ifdef __OPEN_VM
1752         printf("VM/ESA port by Neale Ferguson, 1998\n");
1753 #endif
1754 #ifdef POSIX_BC
1755         printf("BS2000 (POSIX) port by Start Amadeus GmbH, 1998\n");
1756 #endif
1757 #ifdef BINARY_BUILD_NOTICE
1758         BINARY_BUILD_NOTICE;
1759 #endif
1760         printf("\n\
1761 Perl may be copied only under the terms of either the Artistic License or the\n\
1762 GNU General Public License, which may be found in the Perl 5.0 source kit.\n\n\
1763 Complete documentation for Perl, including FAQ lists, should be found on\n\
1764 this system using `man perl' or `perldoc perl'.  If you have access to the\n\
1765 Internet, point your browser at http://www.perl.com/, the Perl Home Page.\n\n");
1766         PerlProc_exit(0);
1767     case 'w':
1768         if (! (PL_dowarn & G_WARN_ALL_MASK))
1769             PL_dowarn |= G_WARN_ON;
1770         s++;
1771         return s;
1772     case 'W':
1773         PL_dowarn = G_WARN_ALL_ON|G_WARN_ON;
1774         PL_compiling.cop_warnings = WARN_ALL ;
1775         s++;
1776         return s;
1777     case 'X':
1778         PL_dowarn = G_WARN_ALL_OFF;
1779         PL_compiling.cop_warnings = WARN_NONE ;
1780         s++;
1781         return s;
1782     case '*':
1783     case ' ':
1784         if (s[1] == '-')        /* Additional switches on #! line. */
1785             return s+2;
1786         break;
1787     case '-':
1788     case 0:
1789 #if defined(WIN32) || !defined(PERL_STRICT_CR)
1790     case '\r':
1791 #endif
1792     case '\n':
1793     case '\t':
1794         break;
1795 #ifdef ALTERNATE_SHEBANG
1796     case 'S':                   /* OS/2 needs -S on "extproc" line. */
1797         break;
1798 #endif
1799     case 'P':
1800         if (PL_preprocess)
1801             return s+1;
1802         /* FALL THROUGH */
1803     default:
1804         croak("Can't emulate -%.1s on #! line",s);
1805     }
1806     return Nullch;
1807 }
1808
1809 /* compliments of Tom Christiansen */
1810
1811 /* unexec() can be found in the Gnu emacs distribution */
1812 /* Known to work with -DUNEXEC and using unexelf.c from GNU emacs-20.2 */
1813
1814 void
1815 my_unexec(void)
1816 {
1817 #ifdef UNEXEC
1818     SV*    prog;
1819     SV*    file;
1820     int    status = 1;
1821     extern int etext;
1822
1823     prog = newSVpv(BIN_EXP, 0);
1824     sv_catpv(prog, "/perl");
1825     file = newSVpv(PL_origfilename, 0);
1826     sv_catpv(file, ".perldump");
1827
1828     unexec(SvPVX(file), SvPVX(prog), &etext, sbrk(0), 0);
1829     /* unexec prints msg to stderr in case of failure */
1830     PerlProc_exit(status);
1831 #else
1832 #  ifdef VMS
1833 #    include <lib$routines.h>
1834      lib$signal(SS$_DEBUG);  /* ssdef.h #included from vmsish.h */
1835 #  else
1836     ABORT();            /* for use with undump */
1837 #  endif
1838 #endif
1839 }
1840
1841 /* initialize curinterp */
1842 STATIC void
1843 init_interp(void)
1844 {
1845
1846 #ifdef PERL_OBJECT              /* XXX kludge */
1847 #define I_REINIT \
1848   STMT_START {                          \
1849     PL_chopset          = " \n-";       \
1850     PL_copline          = NOLINE;       \
1851     PL_curcop           = &PL_compiling;\
1852     PL_curcopdb         = NULL;         \
1853     PL_dbargs           = 0;            \
1854     PL_dlmax            = 128;          \
1855     PL_dumpindent       = 4;            \
1856     PL_laststatval      = -1;           \
1857     PL_laststype        = OP_STAT;      \
1858     PL_maxscream        = -1;           \
1859     PL_maxsysfd         = MAXSYSFD;     \
1860     PL_statname         = Nullsv;       \
1861     PL_tmps_floor       = -1;           \
1862     PL_tmps_ix          = -1;           \
1863     PL_op_mask          = NULL;         \
1864     PL_dlmax            = 128;          \
1865     PL_laststatval      = -1;           \
1866     PL_laststype        = OP_STAT;      \
1867     PL_mess_sv          = Nullsv;       \
1868     PL_splitstr         = " ";          \
1869     PL_generation       = 100;          \
1870     PL_exitlist         = NULL;         \
1871     PL_exitlistlen      = 0;            \
1872     PL_regindent        = 0;            \
1873     PL_in_clean_objs    = FALSE;        \
1874     PL_in_clean_all     = FALSE;        \
1875     PL_profiledata      = NULL;         \
1876     PL_rsfp             = Nullfp;       \
1877     PL_rsfp_filters     = Nullav;       \
1878     PL_dirty            = FALSE;        \
1879   } STMT_END
1880     I_REINIT;
1881 #else
1882 #  ifdef MULTIPLICITY
1883 #    define PERLVAR(var,type)
1884 #    define PERLVARI(var,type,init)     PL_curinterp->var = init;
1885 #    define PERLVARIC(var,type,init)    PL_curinterp->var = init;
1886 #    include "intrpvar.h"
1887 #    ifndef USE_THREADS
1888 #      include "thrdvar.h"
1889 #    endif
1890 #    undef PERLVAR
1891 #    undef PERLVARI
1892 #    undef PERLVARIC
1893 #  else
1894 #    define PERLVAR(var,type)
1895 #    define PERLVARI(var,type,init)     PL_##var = init;
1896 #    define PERLVARIC(var,type,init)    PL_##var = init;
1897 #    include "intrpvar.h"
1898 #    ifndef USE_THREADS
1899 #      include "thrdvar.h"
1900 #    endif
1901 #    undef PERLVAR
1902 #    undef PERLVARI
1903 #    undef PERLVARIC
1904 #  endif
1905 #endif
1906
1907 }
1908
1909 STATIC void
1910 init_main_stash(void)
1911 {
1912     dTHR;
1913     GV *gv;
1914
1915     /* Note that strtab is a rather special HV.  Assumptions are made
1916        about not iterating on it, and not adding tie magic to it.
1917        It is properly deallocated in perl_destruct() */
1918     PL_strtab = newHV();
1919 #ifdef USE_THREADS
1920     MUTEX_INIT(&PL_strtab_mutex);
1921 #endif
1922     HvSHAREKEYS_off(PL_strtab);                 /* mandatory */
1923     hv_ksplit(PL_strtab, 512);
1924
1925     PL_curstash = PL_defstash = newHV();
1926     PL_curstname = newSVpv("main",4);
1927     gv = gv_fetchpv("main::",TRUE, SVt_PVHV);
1928     SvREFCNT_dec(GvHV(gv));
1929     GvHV(gv) = (HV*)SvREFCNT_inc(PL_defstash);
1930     SvREADONLY_on(gv);
1931     HvNAME(PL_defstash) = savepv("main");
1932     PL_incgv = gv_HVadd(gv_AVadd(gv_fetchpv("INC",TRUE, SVt_PVAV)));
1933     GvMULTI_on(PL_incgv);
1934     PL_hintgv = gv_fetchpv("\010",TRUE, SVt_PV); /* ^H */
1935     GvMULTI_on(PL_hintgv);
1936     PL_defgv = gv_fetchpv("_",TRUE, SVt_PVAV);
1937     PL_errgv = gv_HVadd(gv_fetchpv("@", TRUE, SVt_PV));
1938     GvMULTI_on(PL_errgv);
1939     PL_replgv = gv_fetchpv("\022", TRUE, SVt_PV); /* ^R */
1940     GvMULTI_on(PL_replgv);
1941     (void)form("%240s","");     /* Preallocate temp - for immediate signals. */
1942     sv_grow(ERRSV, 240);        /* Preallocate - for immediate signals. */
1943     sv_setpvn(ERRSV, "", 0);
1944     PL_curstash = PL_defstash;
1945     PL_compiling.cop_stash = PL_defstash;
1946     PL_debstash = GvHV(gv_fetchpv("DB::", GV_ADDMULTI, SVt_PVHV));
1947     PL_globalstash = GvHV(gv_fetchpv("CORE::GLOBAL::", GV_ADDMULTI, SVt_PVHV));
1948     /* We must init $/ before switches are processed. */
1949     sv_setpvn(perl_get_sv("/", TRUE), "\n", 1);
1950 }
1951
1952 STATIC void
1953 open_script(char *scriptname, bool dosearch, SV *sv, int *fdscript)
1954 {
1955     dTHR;
1956     register char *s;
1957
1958     *fdscript = -1;
1959
1960     if (PL_e_script) {
1961         PL_origfilename = savepv("-e");
1962     }
1963     else {
1964         /* if find_script() returns, it returns a malloc()-ed value */
1965         PL_origfilename = scriptname = find_script(scriptname, dosearch, NULL, 1);
1966
1967         if (strnEQ(scriptname, "/dev/fd/", 8) && isDIGIT(scriptname[8]) ) {
1968             char *s = scriptname + 8;
1969             *fdscript = atoi(s);
1970             while (isDIGIT(*s))
1971                 s++;
1972             if (*s) {
1973                 scriptname = savepv(s + 1);
1974                 Safefree(PL_origfilename);
1975                 PL_origfilename = scriptname;
1976             }
1977         }
1978     }
1979
1980     PL_curcop->cop_filegv = gv_fetchfile(PL_origfilename);
1981     if (strEQ(PL_origfilename,"-"))
1982         scriptname = "";
1983     if (*fdscript >= 0) {
1984         PL_rsfp = PerlIO_fdopen(*fdscript,PERL_SCRIPT_MODE);
1985 #if defined(HAS_FCNTL) && defined(F_SETFD)
1986         if (PL_rsfp)
1987             fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,1);  /* ensure close-on-exec */
1988 #endif
1989     }
1990     else if (PL_preprocess) {
1991         char *cpp_cfg = CPPSTDIN;
1992         SV *cpp = newSVpv("",0);
1993         SV *cmd = NEWSV(0,0);
1994
1995         if (strEQ(cpp_cfg, "cppstdin"))
1996             sv_catpvf(cpp, "%s/", BIN_EXP);
1997         sv_catpv(cpp, cpp_cfg);
1998
1999         sv_catpv(sv,"-I");
2000         sv_catpv(sv,PRIVLIB_EXP);
2001
2002 #ifdef MSDOS
2003         sv_setpvf(cmd, "\
2004 sed %s -e \"/^[^#]/b\" \
2005  -e \"/^#[      ]*include[      ]/b\" \
2006  -e \"/^#[      ]*define[       ]/b\" \
2007  -e \"/^#[      ]*if[   ]/b\" \
2008  -e \"/^#[      ]*ifdef[        ]/b\" \
2009  -e \"/^#[      ]*ifndef[       ]/b\" \
2010  -e \"/^#[      ]*else/b\" \
2011  -e \"/^#[      ]*elif[         ]/b\" \
2012  -e \"/^#[      ]*undef[        ]/b\" \
2013  -e \"/^#[      ]*endif/b\" \
2014  -e \"s/^#.*//\" \
2015  %s | %_ -C %_ %s",
2016           (PL_doextract ? "-e \"1,/^#/d\n\"" : ""),
2017 #else
2018 #  ifdef __OPEN_VM
2019         sv_setpvf(cmd, "\
2020 %s %s -e '/^[^#]/b' \
2021  -e '/^#[       ]*include[      ]/b' \
2022  -e '/^#[       ]*define[       ]/b' \
2023  -e '/^#[       ]*if[   ]/b' \
2024  -e '/^#[       ]*ifdef[        ]/b' \
2025  -e '/^#[       ]*ifndef[       ]/b' \
2026  -e '/^#[       ]*else/b' \
2027  -e '/^#[       ]*elif[         ]/b' \
2028  -e '/^#[       ]*undef[        ]/b' \
2029  -e '/^#[       ]*endif/b' \
2030  -e 's/^[       ]*#.*//' \
2031  %s | %_ %_ %s",
2032 #  else
2033         sv_setpvf(cmd, "\
2034 %s %s -e '/^[^#]/b' \
2035  -e '/^#[       ]*include[      ]/b' \
2036  -e '/^#[       ]*define[       ]/b' \
2037  -e '/^#[       ]*if[   ]/b' \
2038  -e '/^#[       ]*ifdef[        ]/b' \
2039  -e '/^#[       ]*ifndef[       ]/b' \
2040  -e '/^#[       ]*else/b' \
2041  -e '/^#[       ]*elif[         ]/b' \
2042  -e '/^#[       ]*undef[        ]/b' \
2043  -e '/^#[       ]*endif/b' \
2044  -e 's/^[       ]*#.*//' \
2045  %s | %_ -C %_ %s",
2046 #  endif
2047 #ifdef LOC_SED
2048           LOC_SED,
2049 #else
2050           "sed",
2051 #endif
2052           (PL_doextract ? "-e '1,/^#/d\n'" : ""),
2053 #endif
2054           scriptname, cpp, sv, CPPMINUS);
2055         PL_doextract = FALSE;
2056 #ifdef IAMSUID                          /* actually, this is caught earlier */
2057         if (PL_euid != PL_uid && !PL_euid) {    /* if running suidperl */
2058 #ifdef HAS_SETEUID
2059             (void)seteuid(PL_uid);              /* musn't stay setuid root */
2060 #else
2061 #ifdef HAS_SETREUID
2062             (void)setreuid((Uid_t)-1, PL_uid);
2063 #else
2064 #ifdef HAS_SETRESUID
2065             (void)setresuid((Uid_t)-1, PL_uid, (Uid_t)-1);
2066 #else
2067             PerlProc_setuid(PL_uid);
2068 #endif
2069 #endif
2070 #endif
2071             if (PerlProc_geteuid() != PL_uid)
2072                 croak("Can't do seteuid!\n");
2073         }
2074 #endif /* IAMSUID */
2075         PL_rsfp = PerlProc_popen(SvPVX(cmd), "r");
2076         SvREFCNT_dec(cmd);
2077         SvREFCNT_dec(cpp);
2078     }
2079     else if (!*scriptname) {
2080         forbid_setid("program input from stdin");
2081         PL_rsfp = PerlIO_stdin();
2082     }
2083     else {
2084         PL_rsfp = PerlIO_open(scriptname,PERL_SCRIPT_MODE);
2085 #if defined(HAS_FCNTL) && defined(F_SETFD)
2086         if (PL_rsfp)
2087             fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,1);  /* ensure close-on-exec */
2088 #endif
2089     }
2090     if (!PL_rsfp) {
2091 #ifdef DOSUID
2092 #ifndef IAMSUID         /* in case script is not readable before setuid */
2093         if (PL_euid &&
2094             PerlLIO_stat(SvPVX(GvSV(PL_curcop->cop_filegv)),&PL_statbuf) >= 0 &&
2095             PL_statbuf.st_mode & (S_ISUID|S_ISGID))
2096         {
2097             /* try again */
2098             PerlProc_execv(form("%s/sperl%s", BIN_EXP, PL_patchlevel), PL_origargv);
2099             croak("Can't do setuid\n");
2100         }
2101 #endif
2102 #endif
2103         croak("Can't open perl script \"%s\": %s\n",
2104           SvPVX(GvSV(PL_curcop->cop_filegv)), Strerror(errno));
2105     }
2106 }
2107
2108 STATIC void
2109 validate_suid(char *validarg, char *scriptname, int fdscript)
2110 {
2111     int which;
2112
2113     /* do we need to emulate setuid on scripts? */
2114
2115     /* This code is for those BSD systems that have setuid #! scripts disabled
2116      * in the kernel because of a security problem.  Merely defining DOSUID
2117      * in perl will not fix that problem, but if you have disabled setuid
2118      * scripts in the kernel, this will attempt to emulate setuid and setgid
2119      * on scripts that have those now-otherwise-useless bits set.  The setuid
2120      * root version must be called suidperl or sperlN.NNN.  If regular perl
2121      * discovers that it has opened a setuid script, it calls suidperl with
2122      * the same argv that it had.  If suidperl finds that the script it has
2123      * just opened is NOT setuid root, it sets the effective uid back to the
2124      * uid.  We don't just make perl setuid root because that loses the
2125      * effective uid we had before invoking perl, if it was different from the
2126      * uid.
2127      *
2128      * DOSUID must be defined in both perl and suidperl, and IAMSUID must
2129      * be defined in suidperl only.  suidperl must be setuid root.  The
2130      * Configure script will set this up for you if you want it.
2131      */
2132
2133 #ifdef DOSUID
2134     dTHR;
2135     char *s, *s2;
2136
2137     if (PerlLIO_fstat(PerlIO_fileno(PL_rsfp),&PL_statbuf) < 0)  /* normal stat is insecure */
2138         croak("Can't stat script \"%s\"",PL_origfilename);
2139     if (fdscript < 0 && PL_statbuf.st_mode & (S_ISUID|S_ISGID)) {
2140         I32 len;
2141
2142 #ifdef IAMSUID
2143 #ifndef HAS_SETREUID
2144         /* On this access check to make sure the directories are readable,
2145          * there is actually a small window that the user could use to make
2146          * filename point to an accessible directory.  So there is a faint
2147          * chance that someone could execute a setuid script down in a
2148          * non-accessible directory.  I don't know what to do about that.
2149          * But I don't think it's too important.  The manual lies when
2150          * it says access() is useful in setuid programs.
2151          */
2152         if (PerlLIO_access(SvPVX(GvSV(PL_curcop->cop_filegv)),1)) /*double check*/
2153             croak("Permission denied");
2154 #else
2155         /* If we can swap euid and uid, then we can determine access rights
2156          * with a simple stat of the file, and then compare device and
2157          * inode to make sure we did stat() on the same file we opened.
2158          * Then we just have to make sure he or she can execute it.
2159          */
2160         {
2161             struct stat tmpstatbuf;
2162
2163             if (
2164 #ifdef HAS_SETREUID
2165                 setreuid(PL_euid,PL_uid) < 0
2166 #else
2167 # if HAS_SETRESUID
2168                 setresuid(PL_euid,PL_uid,(Uid_t)-1) < 0
2169 # endif
2170 #endif
2171                 || PerlProc_getuid() != PL_euid || PerlProc_geteuid() != PL_uid)
2172                 croak("Can't swap uid and euid");       /* really paranoid */
2173             if (PerlLIO_stat(SvPVX(GvSV(PL_curcop->cop_filegv)),&tmpstatbuf) < 0)
2174                 croak("Permission denied");     /* testing full pathname here */
2175             if (tmpstatbuf.st_dev != PL_statbuf.st_dev ||
2176                 tmpstatbuf.st_ino != PL_statbuf.st_ino) {
2177                 (void)PerlIO_close(PL_rsfp);
2178                 if (PL_rsfp = PerlProc_popen("/bin/mail root","w")) {   /* heh, heh */
2179                     PerlIO_printf(PL_rsfp,
2180 "User %ld tried to run dev %ld ino %ld in place of dev %ld ino %ld!\n\
2181 (Filename of set-id script was %s, uid %ld gid %ld.)\n\nSincerely,\nperl\n",
2182                         (long)PL_uid,(long)tmpstatbuf.st_dev, (long)tmpstatbuf.st_ino,
2183                         (long)PL_statbuf.st_dev, (long)PL_statbuf.st_ino,
2184                         SvPVX(GvSV(PL_curcop->cop_filegv)),
2185                         (long)PL_statbuf.st_uid, (long)PL_statbuf.st_gid);
2186                     (void)PerlProc_pclose(PL_rsfp);
2187                 }
2188                 croak("Permission denied\n");
2189             }
2190             if (
2191 #ifdef HAS_SETREUID
2192               setreuid(PL_uid,PL_euid) < 0
2193 #else
2194 # if defined(HAS_SETRESUID)
2195               setresuid(PL_uid,PL_euid,(Uid_t)-1) < 0
2196 # endif
2197 #endif
2198               || PerlProc_getuid() != PL_uid || PerlProc_geteuid() != PL_euid)
2199                 croak("Can't reswap uid and euid");
2200             if (!cando(S_IXUSR,FALSE,&PL_statbuf))              /* can real uid exec? */
2201                 croak("Permission denied\n");
2202         }
2203 #endif /* HAS_SETREUID */
2204 #endif /* IAMSUID */
2205
2206         if (!S_ISREG(PL_statbuf.st_mode))
2207             croak("Permission denied");
2208         if (PL_statbuf.st_mode & S_IWOTH)
2209             croak("Setuid/gid script is writable by world");
2210         PL_doswitches = FALSE;          /* -s is insecure in suid */
2211         PL_curcop->cop_line++;
2212         if (sv_gets(PL_linestr, PL_rsfp, 0) == Nullch ||
2213           strnNE(SvPV(PL_linestr,PL_na),"#!",2) )       /* required even on Sys V */
2214             croak("No #! line");
2215         s = SvPV(PL_linestr,PL_na)+2;
2216         if (*s == ' ') s++;
2217         while (!isSPACE(*s)) s++;
2218         for (s2 = s;  (s2 > SvPV(PL_linestr,PL_na)+2 &&
2219                        (isDIGIT(s2[-1]) || strchr("._-", s2[-1])));  s2--) ;
2220         if (strnNE(s2-4,"perl",4) && strnNE(s-9,"perl",4))  /* sanity check */
2221             croak("Not a perl script");
2222         while (*s == ' ' || *s == '\t') s++;
2223         /*
2224          * #! arg must be what we saw above.  They can invoke it by
2225          * mentioning suidperl explicitly, but they may not add any strange
2226          * arguments beyond what #! says if they do invoke suidperl that way.
2227          */
2228         len = strlen(validarg);
2229         if (strEQ(validarg," PHOOEY ") ||
2230             strnNE(s,validarg,len) || !isSPACE(s[len]))
2231             croak("Args must match #! line");
2232
2233 #ifndef IAMSUID
2234         if (PL_euid != PL_uid && (PL_statbuf.st_mode & S_ISUID) &&
2235             PL_euid == PL_statbuf.st_uid)
2236             if (!PL_do_undump)
2237                 croak("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
2238 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
2239 #endif /* IAMSUID */
2240
2241         if (PL_euid) {  /* oops, we're not the setuid root perl */
2242             (void)PerlIO_close(PL_rsfp);
2243 #ifndef IAMSUID
2244             /* try again */
2245             PerlProc_execv(form("%s/sperl%s", BIN_EXP, PL_patchlevel), PL_origargv);
2246 #endif
2247             croak("Can't do setuid\n");
2248         }
2249
2250         if (PL_statbuf.st_mode & S_ISGID && PL_statbuf.st_gid != PL_egid) {
2251 #ifdef HAS_SETEGID
2252             (void)setegid(PL_statbuf.st_gid);
2253 #else
2254 #ifdef HAS_SETREGID
2255            (void)setregid((Gid_t)-1,PL_statbuf.st_gid);
2256 #else
2257 #ifdef HAS_SETRESGID
2258            (void)setresgid((Gid_t)-1,PL_statbuf.st_gid,(Gid_t)-1);
2259 #else
2260             PerlProc_setgid(PL_statbuf.st_gid);
2261 #endif
2262 #endif
2263 #endif
2264             if (PerlProc_getegid() != PL_statbuf.st_gid)
2265                 croak("Can't do setegid!\n");
2266         }
2267         if (PL_statbuf.st_mode & S_ISUID) {
2268             if (PL_statbuf.st_uid != PL_euid)
2269 #ifdef HAS_SETEUID
2270                 (void)seteuid(PL_statbuf.st_uid);       /* all that for this */
2271 #else
2272 #ifdef HAS_SETREUID
2273                 (void)setreuid((Uid_t)-1,PL_statbuf.st_uid);
2274 #else
2275 #ifdef HAS_SETRESUID
2276                 (void)setresuid((Uid_t)-1,PL_statbuf.st_uid,(Uid_t)-1);
2277 #else
2278                 PerlProc_setuid(PL_statbuf.st_uid);
2279 #endif
2280 #endif
2281 #endif
2282             if (PerlProc_geteuid() != PL_statbuf.st_uid)
2283                 croak("Can't do seteuid!\n");
2284         }
2285         else if (PL_uid) {                      /* oops, mustn't run as root */
2286 #ifdef HAS_SETEUID
2287           (void)seteuid((Uid_t)PL_uid);
2288 #else
2289 #ifdef HAS_SETREUID
2290           (void)setreuid((Uid_t)-1,(Uid_t)PL_uid);
2291 #else
2292 #ifdef HAS_SETRESUID
2293           (void)setresuid((Uid_t)-1,(Uid_t)PL_uid,(Uid_t)-1);
2294 #else
2295           PerlProc_setuid((Uid_t)PL_uid);
2296 #endif
2297 #endif
2298 #endif
2299             if (PerlProc_geteuid() != PL_uid)
2300                 croak("Can't do seteuid!\n");
2301         }
2302         init_ids();
2303         if (!cando(S_IXUSR,TRUE,&PL_statbuf))
2304             croak("Permission denied\n");       /* they can't do this */
2305     }
2306 #ifdef IAMSUID
2307     else if (PL_preprocess)
2308         croak("-P not allowed for setuid/setgid script\n");
2309     else if (fdscript >= 0)
2310         croak("fd script not allowed in suidperl\n");
2311     else
2312         croak("Script is not setuid/setgid in suidperl\n");
2313
2314     /* We absolutely must clear out any saved ids here, so we */
2315     /* exec the real perl, substituting fd script for scriptname. */
2316     /* (We pass script name as "subdir" of fd, which perl will grok.) */
2317     PerlIO_rewind(PL_rsfp);
2318     PerlLIO_lseek(PerlIO_fileno(PL_rsfp),(Off_t)0,0);  /* just in case rewind didn't */
2319     for (which = 1; PL_origargv[which] && PL_origargv[which] != scriptname; which++) ;
2320     if (!PL_origargv[which])
2321         croak("Permission denied");
2322     PL_origargv[which] = savepv(form("/dev/fd/%d/%s",
2323                                   PerlIO_fileno(PL_rsfp), PL_origargv[which]));
2324 #if defined(HAS_FCNTL) && defined(F_SETFD)
2325     fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,0);    /* ensure no close-on-exec */
2326 #endif
2327     PerlProc_execv(form("%s/perl%s", BIN_EXP, PL_patchlevel), PL_origargv);/* try again */
2328     croak("Can't do setuid\n");
2329 #endif /* IAMSUID */
2330 #else /* !DOSUID */
2331     if (PL_euid != PL_uid || PL_egid != PL_gid) {       /* (suidperl doesn't exist, in fact) */
2332 #ifndef SETUID_SCRIPTS_ARE_SECURE_NOW
2333         dTHR;
2334         PerlLIO_fstat(PerlIO_fileno(PL_rsfp),&PL_statbuf);      /* may be either wrapped or real suid */
2335         if ((PL_euid != PL_uid && PL_euid == PL_statbuf.st_uid && PL_statbuf.st_mode & S_ISUID)
2336             ||
2337             (PL_egid != PL_gid && PL_egid == PL_statbuf.st_gid && PL_statbuf.st_mode & S_ISGID)
2338            )
2339             if (!PL_do_undump)
2340                 croak("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
2341 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
2342 #endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
2343         /* not set-id, must be wrapped */
2344     }
2345 #endif /* DOSUID */
2346 }
2347
2348 STATIC void
2349 find_beginning(void)
2350 {
2351     register char *s, *s2;
2352
2353     /* skip forward in input to the real script? */
2354
2355     forbid_setid("-x");
2356     while (PL_doextract) {
2357         if ((s = sv_gets(PL_linestr, PL_rsfp, 0)) == Nullch)
2358             croak("No Perl script found in input\n");
2359         if (*s == '#' && s[1] == '!' && (s = instr(s,"perl"))) {
2360             PerlIO_ungetc(PL_rsfp, '\n');               /* to keep line count right */
2361             PL_doextract = FALSE;
2362             while (*s && !(isSPACE (*s) || *s == '#')) s++;
2363             s2 = s;
2364             while (*s == ' ' || *s == '\t') s++;
2365             if (*s++ == '-') {
2366                 while (isDIGIT(s2[-1]) || strchr("-._", s2[-1])) s2--;
2367                 if (strnEQ(s2-4,"perl",4))
2368                     /*SUPPRESS 530*/
2369                     while (s = moreswitches(s)) ;
2370             }
2371             if (PL_cddir && PerlDir_chdir(PL_cddir) < 0)
2372                 croak("Can't chdir to %s",PL_cddir);
2373         }
2374     }
2375 }
2376
2377
2378 STATIC void
2379 init_ids(void)
2380 {
2381     PL_uid = (int)PerlProc_getuid();
2382     PL_euid = (int)PerlProc_geteuid();
2383     PL_gid = (int)PerlProc_getgid();
2384     PL_egid = (int)PerlProc_getegid();
2385 #ifdef VMS
2386     PL_uid |= PL_gid << 16;
2387     PL_euid |= PL_egid << 16;
2388 #endif
2389     PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2390 }
2391
2392 STATIC void
2393 forbid_setid(char *s)
2394 {
2395     if (PL_euid != PL_uid)
2396         croak("No %s allowed while running setuid", s);
2397     if (PL_egid != PL_gid)
2398         croak("No %s allowed while running setgid", s);
2399 }
2400
2401 STATIC void
2402 init_debugger(void)
2403 {
2404     dTHR;
2405     PL_curstash = PL_debstash;
2406     PL_dbargs = GvAV(gv_AVadd((gv_fetchpv("args", GV_ADDMULTI, SVt_PVAV))));
2407     AvREAL_off(PL_dbargs);
2408     PL_DBgv = gv_fetchpv("DB", GV_ADDMULTI, SVt_PVGV);
2409     PL_DBline = gv_fetchpv("dbline", GV_ADDMULTI, SVt_PVAV);
2410     PL_DBsub = gv_HVadd(gv_fetchpv("sub", GV_ADDMULTI, SVt_PVHV));
2411     PL_DBsingle = GvSV((gv_fetchpv("single", GV_ADDMULTI, SVt_PV)));
2412     sv_setiv(PL_DBsingle, 0);
2413     PL_DBtrace = GvSV((gv_fetchpv("trace", GV_ADDMULTI, SVt_PV)));
2414     sv_setiv(PL_DBtrace, 0);
2415     PL_DBsignal = GvSV((gv_fetchpv("signal", GV_ADDMULTI, SVt_PV)));
2416     sv_setiv(PL_DBsignal, 0);
2417     PL_curstash = PL_defstash;
2418 }
2419
2420 #ifndef STRESS_REALLOC
2421 #define REASONABLE(size) (size)
2422 #else
2423 #define REASONABLE(size) (1) /* unreasonable */
2424 #endif
2425
2426 void
2427 init_stacks(ARGSproto)
2428 {
2429     /* start with 128-item stack and 8K cxstack */
2430     PL_curstackinfo = new_stackinfo(REASONABLE(128),
2431                                  REASONABLE(8192/sizeof(PERL_CONTEXT) - 1));
2432     PL_curstackinfo->si_type = PERLSI_MAIN;
2433     PL_curstack = PL_curstackinfo->si_stack;
2434     PL_mainstack = PL_curstack;         /* remember in case we switch stacks */
2435
2436     PL_stack_base = AvARRAY(PL_curstack);
2437     PL_stack_sp = PL_stack_base;
2438     PL_stack_max = PL_stack_base + AvMAX(PL_curstack);
2439
2440     New(50,PL_tmps_stack,REASONABLE(128),SV*);
2441     PL_tmps_floor = -1;
2442     PL_tmps_ix = -1;
2443     PL_tmps_max = REASONABLE(128);
2444
2445     New(54,PL_markstack,REASONABLE(32),I32);
2446     PL_markstack_ptr = PL_markstack;
2447     PL_markstack_max = PL_markstack + REASONABLE(32);
2448
2449     SET_MARKBASE;
2450
2451     New(54,PL_scopestack,REASONABLE(32),I32);
2452     PL_scopestack_ix = 0;
2453     PL_scopestack_max = REASONABLE(32);
2454
2455     New(54,PL_savestack,REASONABLE(128),ANY);
2456     PL_savestack_ix = 0;
2457     PL_savestack_max = REASONABLE(128);
2458
2459     New(54,PL_retstack,REASONABLE(16),OP*);
2460     PL_retstack_ix = 0;
2461     PL_retstack_max = REASONABLE(16);
2462 }
2463
2464 #undef REASONABLE
2465
2466 STATIC void
2467 nuke_stacks(void)
2468 {
2469     dTHR;
2470     while (PL_curstackinfo->si_next)
2471         PL_curstackinfo = PL_curstackinfo->si_next;
2472     while (PL_curstackinfo) {
2473         PERL_SI *p = PL_curstackinfo->si_prev;
2474         /* curstackinfo->si_stack got nuked by sv_free_arenas() */
2475         Safefree(PL_curstackinfo->si_cxstack);
2476         Safefree(PL_curstackinfo);
2477         PL_curstackinfo = p;
2478     }
2479     Safefree(PL_tmps_stack);
2480     Safefree(PL_markstack);
2481     Safefree(PL_scopestack);
2482     Safefree(PL_savestack);
2483     Safefree(PL_retstack);
2484     DEBUG( {
2485         Safefree(PL_debname);
2486         Safefree(PL_debdelim);
2487     } )
2488 }
2489
2490 #ifndef PERL_OBJECT
2491 static PerlIO *tmpfp;  /* moved outside init_lexer() because of UNICOS bug */
2492 #endif
2493
2494 STATIC void
2495 init_lexer(void)
2496 {
2497 #ifdef PERL_OBJECT
2498         PerlIO *tmpfp;
2499 #endif
2500     tmpfp = PL_rsfp;
2501     PL_rsfp = Nullfp;
2502     lex_start(PL_linestr);
2503     PL_rsfp = tmpfp;
2504     PL_subname = newSVpv("main",4);
2505 }
2506
2507 STATIC void
2508 init_predump_symbols(void)
2509 {
2510     dTHR;
2511     GV *tmpgv;
2512     GV *othergv;
2513
2514     sv_setpvn(perl_get_sv("\"", TRUE), " ", 1);
2515     PL_stdingv = gv_fetchpv("STDIN",TRUE, SVt_PVIO);
2516     GvMULTI_on(PL_stdingv);
2517     IoIFP(GvIOp(PL_stdingv)) = PerlIO_stdin();
2518     tmpgv = gv_fetchpv("stdin",TRUE, SVt_PV);
2519     GvMULTI_on(tmpgv);
2520     GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(PL_stdingv));
2521
2522     tmpgv = gv_fetchpv("STDOUT",TRUE, SVt_PVIO);
2523     GvMULTI_on(tmpgv);
2524     IoOFP(GvIOp(tmpgv)) = IoIFP(GvIOp(tmpgv)) = PerlIO_stdout();
2525     setdefout(tmpgv);
2526     tmpgv = gv_fetchpv("stdout",TRUE, SVt_PV);
2527     GvMULTI_on(tmpgv);
2528     GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(PL_defoutgv));
2529
2530     othergv = gv_fetchpv("STDERR",TRUE, SVt_PVIO);
2531     GvMULTI_on(othergv);
2532     IoOFP(GvIOp(othergv)) = IoIFP(GvIOp(othergv)) = PerlIO_stderr();
2533     tmpgv = gv_fetchpv("stderr",TRUE, SVt_PV);
2534     GvMULTI_on(tmpgv);
2535     GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(othergv));
2536
2537     PL_statname = NEWSV(66,0);          /* last filename we did stat on */
2538
2539     if (!PL_osname)
2540         PL_osname = savepv(OSNAME);
2541 }
2542
2543 STATIC void
2544 init_postdump_symbols(register int argc, register char **argv, register char **env)
2545 {
2546     dTHR;
2547     char *s;
2548     SV *sv;
2549     GV* tmpgv;
2550
2551     argc--,argv++;      /* skip name of script */
2552     if (PL_doswitches) {
2553         for (; argc > 0 && **argv == '-'; argc--,argv++) {
2554             if (!argv[0][1])
2555                 break;
2556             if (argv[0][1] == '-') {
2557                 argc--,argv++;
2558                 break;
2559             }
2560             if (s = strchr(argv[0], '=')) {
2561                 *s++ = '\0';
2562                 sv_setpv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),s);
2563             }
2564             else
2565                 sv_setiv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),1);
2566         }
2567     }
2568     PL_toptarget = NEWSV(0,0);
2569     sv_upgrade(PL_toptarget, SVt_PVFM);
2570     sv_setpvn(PL_toptarget, "", 0);
2571     PL_bodytarget = NEWSV(0,0);
2572     sv_upgrade(PL_bodytarget, SVt_PVFM);
2573     sv_setpvn(PL_bodytarget, "", 0);
2574     PL_formtarget = PL_bodytarget;
2575
2576     TAINT;
2577     if (tmpgv = gv_fetchpv("0",TRUE, SVt_PV)) {
2578         sv_setpv(GvSV(tmpgv),PL_origfilename);
2579         magicname("0", "0", 1);
2580     }
2581     if (tmpgv = gv_fetchpv("\030",TRUE, SVt_PV))
2582         sv_setpv(GvSV(tmpgv),PL_origargv[0]);
2583     if (PL_argvgv = gv_fetchpv("ARGV",TRUE, SVt_PVAV)) {
2584         GvMULTI_on(PL_argvgv);
2585         (void)gv_AVadd(PL_argvgv);
2586         av_clear(GvAVn(PL_argvgv));
2587         for (; argc > 0; argc--,argv++) {
2588             av_push(GvAVn(PL_argvgv),newSVpv(argv[0],0));
2589         }
2590     }
2591     if (PL_envgv = gv_fetchpv("ENV",TRUE, SVt_PVHV)) {
2592         HV *hv;
2593         GvMULTI_on(PL_envgv);
2594         hv = GvHVn(PL_envgv);
2595         hv_magic(hv, PL_envgv, 'E');
2596 #ifndef VMS  /* VMS doesn't have environ array */
2597         /* Note that if the supplied env parameter is actually a copy
2598            of the global environ then it may now point to free'd memory
2599            if the environment has been modified since. To avoid this
2600            problem we treat env==NULL as meaning 'use the default'
2601         */
2602         if (!env)
2603             env = environ;
2604         if (env != environ)
2605             environ[0] = Nullch;
2606         for (; *env; env++) {
2607             if (!(s = strchr(*env,'=')))
2608                 continue;
2609             *s++ = '\0';
2610 #if defined(MSDOS)
2611             (void)strupr(*env);
2612 #endif
2613             sv = newSVpv(s--,0);
2614             (void)hv_store(hv, *env, s - *env, sv, 0);
2615             *s = '=';
2616 #if defined(__BORLANDC__) && defined(USE_WIN32_RTL_ENV)
2617             /* Sins of the RTL. See note in my_setenv(). */
2618             (void)PerlEnv_putenv(savepv(*env));
2619 #endif
2620         }
2621 #endif
2622 #ifdef DYNAMIC_ENV_FETCH
2623         HvNAME(hv) = savepv(ENV_HV_NAME);
2624 #endif
2625     }
2626     TAINT_NOT;
2627     if (tmpgv = gv_fetchpv("$",TRUE, SVt_PV))
2628         sv_setiv(GvSV(tmpgv), (IV)getpid());
2629 }
2630
2631 STATIC void
2632 init_perllib(void)
2633 {
2634     char *s;
2635     if (!PL_tainting) {
2636 #ifndef VMS
2637         s = PerlEnv_getenv("PERL5LIB");
2638         if (s)
2639             incpush(s, TRUE);
2640         else
2641             incpush(PerlEnv_getenv("PERLLIB"), FALSE);
2642 #else /* VMS */
2643         /* Treat PERL5?LIB as a possible search list logical name -- the
2644          * "natural" VMS idiom for a Unix path string.  We allow each
2645          * element to be a set of |-separated directories for compatibility.
2646          */
2647         char buf[256];
2648         int idx = 0;
2649         if (my_trnlnm("PERL5LIB",buf,0))
2650             do { incpush(buf,TRUE); } while (my_trnlnm("PERL5LIB",buf,++idx));
2651         else
2652             while (my_trnlnm("PERLLIB",buf,idx++)) incpush(buf,FALSE);
2653 #endif /* VMS */
2654     }
2655
2656 /* Use the ~-expanded versions of APPLLIB (undocumented),
2657     ARCHLIB PRIVLIB SITEARCH and SITELIB
2658 */
2659 #ifdef APPLLIB_EXP
2660     incpush(APPLLIB_EXP, TRUE);
2661 #endif
2662
2663 #ifdef ARCHLIB_EXP
2664     incpush(ARCHLIB_EXP, FALSE);
2665 #endif
2666 #ifndef PRIVLIB_EXP
2667 #define PRIVLIB_EXP "/usr/local/lib/perl5:/usr/local/lib/perl"
2668 #endif
2669 #if defined(WIN32)
2670     incpush(PRIVLIB_EXP, TRUE);
2671 #else
2672     incpush(PRIVLIB_EXP, FALSE);
2673 #endif
2674
2675 #ifdef SITEARCH_EXP
2676     incpush(SITEARCH_EXP, FALSE);
2677 #endif
2678 #ifdef SITELIB_EXP
2679 #if defined(WIN32)
2680     incpush(SITELIB_EXP, TRUE);
2681 #else
2682     incpush(SITELIB_EXP, FALSE);
2683 #endif
2684 #endif
2685     if (!PL_tainting)
2686         incpush(".", FALSE);
2687 }
2688
2689 #if defined(DOSISH)
2690 #    define PERLLIB_SEP ';'
2691 #else
2692 #  if defined(VMS)
2693 #    define PERLLIB_SEP '|'
2694 #  else
2695 #    define PERLLIB_SEP ':'
2696 #  endif
2697 #endif
2698 #ifndef PERLLIB_MANGLE
2699 #  define PERLLIB_MANGLE(s,n) (s)
2700 #endif
2701
2702 STATIC void
2703 incpush(char *p, int addsubdirs)
2704 {
2705     SV *subdir = Nullsv;
2706
2707     if (!p)
2708         return;
2709
2710     if (addsubdirs) {
2711         subdir = sv_newmortal();
2712         if (!PL_archpat_auto) {
2713             STRLEN len = (sizeof(ARCHNAME) + strlen(PL_patchlevel)
2714                           + sizeof("//auto"));
2715             New(55, PL_archpat_auto, len, char);
2716             sprintf(PL_archpat_auto, "/%s/%s/auto", ARCHNAME, PL_patchlevel);
2717 #ifdef VMS
2718         for (len = sizeof(ARCHNAME) + 2;
2719              PL_archpat_auto[len] != '\0' && PL_archpat_auto[len] != '/'; len++)
2720                 if (PL_archpat_auto[len] == '.') PL_archpat_auto[len] = '_';
2721 #endif
2722         }
2723     }
2724
2725     /* Break at all separators */
2726     while (p && *p) {
2727         SV *libdir = NEWSV(55,0);
2728         char *s;
2729
2730         /* skip any consecutive separators */
2731         while ( *p == PERLLIB_SEP ) {
2732             /* Uncomment the next line for PATH semantics */
2733             /* av_push(GvAVn(PL_incgv), newSVpv(".", 1)); */
2734             p++;
2735         }
2736
2737         if ( (s = strchr(p, PERLLIB_SEP)) != Nullch ) {
2738             sv_setpvn(libdir, PERLLIB_MANGLE(p, (STRLEN)(s - p)),
2739                       (STRLEN)(s - p));
2740             p = s + 1;
2741         }
2742         else {
2743             sv_setpv(libdir, PERLLIB_MANGLE(p, 0));
2744             p = Nullch; /* break out */
2745         }
2746
2747         /*
2748          * BEFORE pushing libdir onto @INC we may first push version- and
2749          * archname-specific sub-directories.
2750          */
2751         if (addsubdirs) {
2752             struct stat tmpstatbuf;
2753 #ifdef VMS
2754             char *unix;
2755             STRLEN len;
2756
2757             if ((unix = tounixspec_ts(SvPV(libdir,PL_na),Nullch)) != Nullch) {
2758                 len = strlen(unix);
2759                 while (unix[len-1] == '/') len--;  /* Cosmetic */
2760                 sv_usepvn(libdir,unix,len);
2761             }
2762             else
2763                 PerlIO_printf(PerlIO_stderr(),
2764                               "Failed to unixify @INC element \"%s\"\n",
2765                               SvPV(libdir,PL_na));
2766 #endif
2767             /* .../archname/version if -d .../archname/version/auto */
2768             sv_setsv(subdir, libdir);
2769             sv_catpv(subdir, PL_archpat_auto);
2770             if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
2771                   S_ISDIR(tmpstatbuf.st_mode))
2772                 av_push(GvAVn(PL_incgv),
2773                         newSVpv(SvPVX(subdir), SvCUR(subdir) - sizeof "auto"));
2774
2775             /* .../archname if -d .../archname/auto */
2776             sv_insert(subdir, SvCUR(libdir) + sizeof(ARCHNAME),
2777                       strlen(PL_patchlevel) + 1, "", 0);
2778             if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
2779                   S_ISDIR(tmpstatbuf.st_mode))
2780                 av_push(GvAVn(PL_incgv),
2781                         newSVpv(SvPVX(subdir), SvCUR(subdir) - sizeof "auto"));
2782         }
2783
2784         /* finally push this lib directory on the end of @INC */
2785         av_push(GvAVn(PL_incgv), libdir);
2786     }
2787 }
2788
2789 #ifdef USE_THREADS
2790 STATIC struct perl_thread *
2791 init_main_thread()
2792 {
2793     struct perl_thread *thr;
2794     XPV *xpv;
2795
2796     Newz(53, thr, 1, struct perl_thread);
2797     PL_curcop = &PL_compiling;
2798     thr->cvcache = newHV();
2799     thr->threadsv = newAV();
2800     /* thr->threadsvp is set when find_threadsv is called */
2801     thr->specific = newAV();
2802     thr->errhv = newHV();
2803     thr->flags = THRf_R_JOINABLE;
2804     MUTEX_INIT(&thr->mutex);
2805     /* Handcraft thrsv similarly to mess_sv */
2806     New(53, PL_thrsv, 1, SV);
2807     Newz(53, xpv, 1, XPV);
2808     SvFLAGS(PL_thrsv) = SVt_PV;
2809     SvANY(PL_thrsv) = (void*)xpv;
2810     SvREFCNT(PL_thrsv) = 1 << 30;       /* practically infinite */
2811     SvPVX(PL_thrsv) = (char*)thr;
2812     SvCUR_set(PL_thrsv, sizeof(thr));
2813     SvLEN_set(PL_thrsv, sizeof(thr));
2814     *SvEND(PL_thrsv) = '\0';    /* in the trailing_nul field */
2815     thr->oursv = PL_thrsv;
2816     PL_chopset = " \n-";
2817     PL_dumpindent = 4;
2818
2819     MUTEX_LOCK(&PL_threads_mutex);
2820     PL_nthreads++;
2821     thr->tid = 0;
2822     thr->next = thr;
2823     thr->prev = thr;
2824     MUTEX_UNLOCK(&PL_threads_mutex);
2825
2826 #ifdef HAVE_THREAD_INTERN
2827     init_thread_intern(thr);
2828 #endif
2829
2830 #ifdef SET_THREAD_SELF
2831     SET_THREAD_SELF(thr);
2832 #else
2833     thr->self = pthread_self();
2834 #endif /* SET_THREAD_SELF */
2835     SET_THR(thr);
2836
2837     /*
2838      * These must come after the SET_THR because sv_setpvn does
2839      * SvTAINT and the taint fields require dTHR.
2840      */
2841     PL_toptarget = NEWSV(0,0);
2842     sv_upgrade(PL_toptarget, SVt_PVFM);
2843     sv_setpvn(PL_toptarget, "", 0);
2844     PL_bodytarget = NEWSV(0,0);
2845     sv_upgrade(PL_bodytarget, SVt_PVFM);
2846     sv_setpvn(PL_bodytarget, "", 0);
2847     PL_formtarget = PL_bodytarget;
2848     thr->errsv = newSVpv("", 0);
2849     (void) find_threadsv("@");  /* Ensure $@ is initialised early */
2850
2851     PL_maxscream = -1;
2852     PL_regcompp = FUNC_NAME_TO_PTR(pregcomp);
2853     PL_regexecp = FUNC_NAME_TO_PTR(regexec_flags);
2854     PL_regindent = 0;
2855     PL_reginterp_cnt = 0;
2856
2857     return thr;
2858 }
2859 #endif /* USE_THREADS */
2860
2861 void
2862 call_list(I32 oldscope, AV *paramList)
2863 {
2864     dTHR;
2865     line_t oldline = PL_curcop->cop_line;
2866     STRLEN len;
2867     dJMPENV;
2868     int ret;
2869
2870     while (AvFILL(paramList) >= 0) {
2871         CV *cv = (CV*)av_shift(paramList);
2872
2873         SAVEFREESV(cv);
2874
2875         JMPENV_PUSH(ret);
2876         switch (ret) {
2877         case 0: {
2878                 SV* atsv = ERRSV;
2879                 PUSHMARK(PL_stack_sp);
2880                 perl_call_sv((SV*)cv, G_EVAL|G_DISCARD);
2881                 (void)SvPV(atsv, len);
2882                 if (len) {
2883                     JMPENV_POP;
2884                     PL_curcop = &PL_compiling;
2885                     PL_curcop->cop_line = oldline;
2886                     if (paramList == PL_beginav)
2887                         sv_catpv(atsv, "BEGIN failed--compilation aborted");
2888                     else
2889                         sv_catpv(atsv, "END failed--cleanup aborted");
2890                     while (PL_scopestack_ix > oldscope)
2891                         LEAVE;
2892                     croak("%s", SvPVX(atsv));
2893                 }
2894             }
2895             break;
2896         case 1:
2897             STATUS_ALL_FAILURE;
2898             /* FALL THROUGH */
2899         case 2:
2900             /* my_exit() was called */
2901             while (PL_scopestack_ix > oldscope)
2902                 LEAVE;
2903             FREETMPS;
2904             PL_curstash = PL_defstash;
2905             if (PL_endav)
2906                 call_list(oldscope, PL_endav);
2907             JMPENV_POP;
2908             PL_curcop = &PL_compiling;
2909             PL_curcop->cop_line = oldline;
2910             if (PL_statusvalue) {
2911                 if (paramList == PL_beginav)
2912                     croak("BEGIN failed--compilation aborted");
2913                 else
2914                     croak("END failed--cleanup aborted");
2915             }
2916             my_exit_jump();
2917             /* NOTREACHED */
2918         case 3:
2919             if (!PL_restartop) {
2920                 PerlIO_printf(PerlIO_stderr(), "panic: restartop\n");
2921                 FREETMPS;
2922                 break;
2923             }
2924             JMPENV_POP;
2925             PL_curcop = &PL_compiling;
2926             PL_curcop->cop_line = oldline;
2927             JMPENV_JUMP(3);
2928         }
2929         JMPENV_POP;
2930     }
2931 }
2932
2933 void
2934 my_exit(U32 status)
2935 {
2936     dTHR;
2937
2938     DEBUG_S(PerlIO_printf(Perl_debug_log, "my_exit: thread %p, status %lu\n",
2939                           thr, (unsigned long) status));
2940     switch (status) {
2941     case 0:
2942         STATUS_ALL_SUCCESS;
2943         break;
2944     case 1:
2945         STATUS_ALL_FAILURE;
2946         break;
2947     default:
2948         STATUS_NATIVE_SET(status);
2949         break;
2950     }
2951     my_exit_jump();
2952 }
2953
2954 void
2955 my_failure_exit(void)
2956 {
2957 #ifdef VMS
2958     if (vaxc$errno & 1) {
2959         if (STATUS_NATIVE & 1)          /* fortuitiously includes "-1" */
2960             STATUS_NATIVE_SET(44);
2961     }
2962     else {
2963         if (!vaxc$errno && errno)       /* unlikely */
2964             STATUS_NATIVE_SET(44);
2965         else
2966             STATUS_NATIVE_SET(vaxc$errno);
2967     }
2968 #else
2969     int exitstatus;
2970     if (errno & 255)
2971         STATUS_POSIX_SET(errno);
2972     else {
2973         exitstatus = STATUS_POSIX >> 8;
2974         if (exitstatus & 255)
2975             STATUS_POSIX_SET(exitstatus);
2976         else
2977             STATUS_POSIX_SET(255);
2978     }
2979 #endif
2980     my_exit_jump();
2981 }
2982
2983 STATIC void
2984 my_exit_jump(void)
2985 {
2986     dTHR;
2987     register PERL_CONTEXT *cx;
2988     I32 gimme;
2989     SV **newsp;
2990
2991     if (PL_e_script) {
2992         SvREFCNT_dec(PL_e_script);
2993         PL_e_script = Nullsv;
2994     }
2995
2996     POPSTACK_TO(PL_mainstack);
2997     if (cxstack_ix >= 0) {
2998         if (cxstack_ix > 0)
2999             dounwind(0);
3000         POPBLOCK(cx,PL_curpm);
3001         LEAVE;
3002     }
3003
3004     JMPENV_JUMP(2);
3005 }
3006
3007 #ifdef PERL_OBJECT
3008 #define NO_XSLOCKS
3009 #endif  /* PERL_OBJECT */
3010
3011 #include "XSUB.h"
3012
3013 static I32
3014 #ifdef PERL_OBJECT
3015 read_e_script(CPerlObj *pPerl, int idx, SV *buf_sv, int maxlen)
3016 #else
3017 read_e_script(int idx, SV *buf_sv, int maxlen)
3018 #endif
3019 {
3020     char *p, *nl;
3021     p  = SvPVX(PL_e_script);
3022     nl = strchr(p, '\n');
3023     nl = (nl) ? nl+1 : SvEND(PL_e_script);
3024     if (nl-p == 0) {
3025         filter_del(read_e_script);
3026         return 0;
3027     }
3028     sv_catpvn(buf_sv, p, nl-p);
3029     sv_chop(PL_e_script, nl);
3030     return 1;
3031 }
3032
3033