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