perl.c

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