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