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