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