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 BINARY_BUILD_NOTICE
1762         BINARY_BUILD_NOTICE;
1763 #endif
1764         printf("\n\
1765 Perl may be copied only under the terms of either the Artistic License or the\n\
1766 GNU General Public License, which may be found in the Perl 5.0 source kit.\n\n\
1767 Complete documentation for Perl, including FAQ lists, should be found on\n\
1768 this system using `man perl' or `perldoc perl'.  If you have access to the\n\
1769 Internet, point your browser at http://www.perl.com/, the Perl Home Page.\n\n");
1770         PerlProc_exit(0);
1771     case 'w':
1772         if (! (PL_dowarn & G_WARN_ALL_MASK))
1773             PL_dowarn |= G_WARN_ON;
1774         s++;
1775         return s;
1776     case 'W':
1777         PL_dowarn = G_WARN_ALL_ON|G_WARN_ON;
1778         PL_compiling.cop_warnings = WARN_ALL ;
1779         s++;
1780         return s;
1781     case 'X':
1782         PL_dowarn = G_WARN_ALL_OFF;
1783         PL_compiling.cop_warnings = WARN_NONE ;
1784         s++;
1785         return s;
1786     case '*':
1787     case ' ':
1788         if (s[1] == '-')        /* Additional switches on #! line. */
1789             return s+2;
1790         break;
1791     case '-':
1792     case 0:
1793 #if defined(WIN32) || !defined(PERL_STRICT_CR)
1794     case '\r':
1795 #endif
1796     case '\n':
1797     case '\t':
1798         break;
1799 #ifdef ALTERNATE_SHEBANG
1800     case 'S':                   /* OS/2 needs -S on "extproc" line. */
1801         break;
1802 #endif
1803     case 'P':
1804         if (PL_preprocess)
1805             return s+1;
1806         /* FALL THROUGH */
1807     default:
1808         croak("Can't emulate -%.1s on #! line",s);
1809     }
1810     return Nullch;
1811 }
1812
1813 /* compliments of Tom Christiansen */
1814
1815 /* unexec() can be found in the Gnu emacs distribution */
1816 /* Known to work with -DUNEXEC and using unexelf.c from GNU emacs-20.2 */
1817
1818 void
1819 my_unexec(void)
1820 {
1821 #ifdef UNEXEC
1822     SV*    prog;
1823     SV*    file;
1824     int    status = 1;
1825     extern int etext;
1826
1827     prog = newSVpv(BIN_EXP, 0);
1828     sv_catpv(prog, "/perl");
1829     file = newSVpv(PL_origfilename, 0);
1830     sv_catpv(file, ".perldump");
1831
1832     unexec(SvPVX(file), SvPVX(prog), &etext, sbrk(0), 0);
1833     /* unexec prints msg to stderr in case of failure */
1834     PerlProc_exit(status);
1835 #else
1836 #  ifdef VMS
1837 #    include <lib$routines.h>
1838      lib$signal(SS$_DEBUG);  /* ssdef.h #included from vmsish.h */
1839 #  else
1840     ABORT();            /* for use with undump */
1841 #  endif
1842 #endif
1843 }
1844
1845 /* initialize curinterp */
1846 STATIC void
1847 init_interp(void)
1848 {
1849
1850 #ifdef PERL_OBJECT              /* XXX kludge */
1851 #define I_REINIT \
1852   STMT_START {                          \
1853     PL_chopset          = " \n-";       \
1854     PL_copline          = NOLINE;       \
1855     PL_curcop           = &PL_compiling;\
1856     PL_curcopdb         = NULL;         \
1857     PL_dbargs           = 0;            \
1858     PL_dlmax            = 128;          \
1859     PL_dumpindent       = 4;            \
1860     PL_laststatval      = -1;           \
1861     PL_laststype        = OP_STAT;      \
1862     PL_maxscream        = -1;           \
1863     PL_maxsysfd         = MAXSYSFD;     \
1864     PL_statname         = Nullsv;       \
1865     PL_tmps_floor       = -1;           \
1866     PL_tmps_ix          = -1;           \
1867     PL_op_mask          = NULL;         \
1868     PL_dlmax            = 128;          \
1869     PL_laststatval      = -1;           \
1870     PL_laststype        = OP_STAT;      \
1871     PL_mess_sv          = Nullsv;       \
1872     PL_splitstr         = " ";          \
1873     PL_generation       = 100;          \
1874     PL_exitlist         = NULL;         \
1875     PL_exitlistlen      = 0;            \
1876     PL_regindent        = 0;            \
1877     PL_in_clean_objs    = FALSE;        \
1878     PL_in_clean_all     = FALSE;        \
1879     PL_profiledata      = NULL;         \
1880     PL_rsfp             = Nullfp;       \
1881     PL_rsfp_filters     = Nullav;       \
1882     PL_dirty            = FALSE;        \
1883   } STMT_END
1884     I_REINIT;
1885 #else
1886 #  ifdef MULTIPLICITY
1887 #    define PERLVAR(var,type)
1888 #    define PERLVARI(var,type,init)     PL_curinterp->var = init;
1889 #    define PERLVARIC(var,type,init)    PL_curinterp->var = init;
1890 #    include "intrpvar.h"
1891 #    ifndef USE_THREADS
1892 #      include "thrdvar.h"
1893 #    endif
1894 #    undef PERLVAR
1895 #    undef PERLVARI
1896 #    undef PERLVARIC
1897 #  else
1898 #    define PERLVAR(var,type)
1899 #    define PERLVARI(var,type,init)     PL_##var = init;
1900 #    define PERLVARIC(var,type,init)    PL_##var = init;
1901 #    include "intrpvar.h"
1902 #    ifndef USE_THREADS
1903 #      include "thrdvar.h"
1904 #    endif
1905 #    undef PERLVAR
1906 #    undef PERLVARI
1907 #    undef PERLVARIC
1908 #  endif
1909 #endif
1910
1911 }
1912
1913 STATIC void
1914 init_main_stash(void)
1915 {
1916     dTHR;
1917     GV *gv;
1918
1919     /* Note that strtab is a rather special HV.  Assumptions are made
1920        about not iterating on it, and not adding tie magic to it.
1921        It is properly deallocated in perl_destruct() */
1922     PL_strtab = newHV();
1923 #ifdef USE_THREADS
1924     MUTEX_INIT(&PL_strtab_mutex);
1925 #endif
1926     HvSHAREKEYS_off(PL_strtab);                 /* mandatory */
1927     hv_ksplit(PL_strtab, 512);
1928
1929     PL_curstash = PL_defstash = newHV();
1930     PL_curstname = newSVpv("main",4);
1931     gv = gv_fetchpv("main::",TRUE, SVt_PVHV);
1932     SvREFCNT_dec(GvHV(gv));
1933     GvHV(gv) = (HV*)SvREFCNT_inc(PL_defstash);
1934     SvREADONLY_on(gv);
1935     HvNAME(PL_defstash) = savepv("main");
1936     PL_incgv = gv_HVadd(gv_AVadd(gv_fetchpv("INC",TRUE, SVt_PVAV)));
1937     GvMULTI_on(PL_incgv);
1938     PL_hintgv = gv_fetchpv("\010",TRUE, SVt_PV); /* ^H */
1939     GvMULTI_on(PL_hintgv);
1940     PL_defgv = gv_fetchpv("_",TRUE, SVt_PVAV);
1941     PL_errgv = gv_HVadd(gv_fetchpv("@", TRUE, SVt_PV));
1942     GvMULTI_on(PL_errgv);
1943     PL_replgv = gv_fetchpv("\022", TRUE, SVt_PV); /* ^R */
1944     GvMULTI_on(PL_replgv);
1945     (void)form("%240s","");     /* Preallocate temp - for immediate signals. */
1946     sv_grow(ERRSV, 240);        /* Preallocate - for immediate signals. */
1947     sv_setpvn(ERRSV, "", 0);
1948     PL_curstash = PL_defstash;
1949     PL_compiling.cop_stash = PL_defstash;
1950     PL_debstash = GvHV(gv_fetchpv("DB::", GV_ADDMULTI, SVt_PVHV));
1951     PL_globalstash = GvHV(gv_fetchpv("CORE::GLOBAL::", GV_ADDMULTI, SVt_PVHV));
1952     /* We must init $/ before switches are processed. */
1953     sv_setpvn(perl_get_sv("/", TRUE), "\n", 1);
1954 }
1955
1956 STATIC void
1957 open_script(char *scriptname, bool dosearch, SV *sv, int *fdscript)
1958 {
1959     dTHR;
1960     register char *s;
1961
1962     *fdscript = -1;
1963
1964     if (PL_e_script) {
1965         PL_origfilename = savepv("-e");
1966     }
1967     else {
1968         /* if find_script() returns, it returns a malloc()-ed value */
1969         PL_origfilename = scriptname = find_script(scriptname, dosearch, NULL, 1);
1970
1971         if (strnEQ(scriptname, "/dev/fd/", 8) && isDIGIT(scriptname[8]) ) {
1972             char *s = scriptname + 8;
1973             *fdscript = atoi(s);
1974             while (isDIGIT(*s))
1975                 s++;
1976             if (*s) {
1977                 scriptname = savepv(s + 1);
1978                 Safefree(PL_origfilename);
1979                 PL_origfilename = scriptname;
1980             }
1981         }
1982     }
1983
1984     PL_curcop->cop_filegv = gv_fetchfile(PL_origfilename);
1985     if (strEQ(PL_origfilename,"-"))
1986         scriptname = "";
1987     if (*fdscript >= 0) {
1988         PL_rsfp = PerlIO_fdopen(*fdscript,PERL_SCRIPT_MODE);
1989 #if defined(HAS_FCNTL) && defined(F_SETFD)
1990         if (PL_rsfp)
1991             fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,1);  /* ensure close-on-exec */
1992 #endif
1993     }
1994     else if (PL_preprocess) {
1995         char *cpp_cfg = CPPSTDIN;
1996         SV *cpp = newSVpv("",0);
1997         SV *cmd = NEWSV(0,0);
1998
1999         if (strEQ(cpp_cfg, "cppstdin"))
2000             sv_catpvf(cpp, "%s/", BIN_EXP);
2001         sv_catpv(cpp, cpp_cfg);
2002
2003         sv_catpv(sv,"-I");
2004         sv_catpv(sv,PRIVLIB_EXP);
2005
2006 #ifdef MSDOS
2007         sv_setpvf(cmd, "\
2008 sed %s -e \"/^[^#]/b\" \
2009  -e \"/^#[      ]*include[      ]/b\" \
2010  -e \"/^#[      ]*define[       ]/b\" \
2011  -e \"/^#[      ]*if[   ]/b\" \
2012  -e \"/^#[      ]*ifdef[        ]/b\" \
2013  -e \"/^#[      ]*ifndef[       ]/b\" \
2014  -e \"/^#[      ]*else/b\" \
2015  -e \"/^#[      ]*elif[         ]/b\" \
2016  -e \"/^#[      ]*undef[        ]/b\" \
2017  -e \"/^#[      ]*endif/b\" \
2018  -e \"s/^#.*//\" \
2019  %s | %_ -C %_ %s",
2020           (PL_doextract ? "-e \"1,/^#/d\n\"" : ""),
2021 #else
2022 #  ifdef __OPEN_VM
2023         sv_setpvf(cmd, "\
2024 %s %s -e '/^[^#]/b' \
2025  -e '/^#[       ]*include[      ]/b' \
2026  -e '/^#[       ]*define[       ]/b' \
2027  -e '/^#[       ]*if[   ]/b' \
2028  -e '/^#[       ]*ifdef[        ]/b' \
2029  -e '/^#[       ]*ifndef[       ]/b' \
2030  -e '/^#[       ]*else/b' \
2031  -e '/^#[       ]*elif[         ]/b' \
2032  -e '/^#[       ]*undef[        ]/b' \
2033  -e '/^#[       ]*endif/b' \
2034  -e 's/^[       ]*#.*//' \
2035  %s | %_ %_ %s",
2036 #  else
2037         sv_setpvf(cmd, "\
2038 %s %s -e '/^[^#]/b' \
2039  -e '/^#[       ]*include[      ]/b' \
2040  -e '/^#[       ]*define[       ]/b' \
2041  -e '/^#[       ]*if[   ]/b' \
2042  -e '/^#[       ]*ifdef[        ]/b' \
2043  -e '/^#[       ]*ifndef[       ]/b' \
2044  -e '/^#[       ]*else/b' \
2045  -e '/^#[       ]*elif[         ]/b' \
2046  -e '/^#[       ]*undef[        ]/b' \
2047  -e '/^#[       ]*endif/b' \
2048  -e 's/^[       ]*#.*//' \
2049  %s | %_ -C %_ %s",
2050 #  endif
2051 #ifdef LOC_SED
2052           LOC_SED,
2053 #else
2054           "sed",
2055 #endif
2056           (PL_doextract ? "-e '1,/^#/d\n'" : ""),
2057 #endif
2058           scriptname, cpp, sv, CPPMINUS);
2059         PL_doextract = FALSE;
2060 #ifdef IAMSUID                          /* actually, this is caught earlier */
2061         if (PL_euid != PL_uid && !PL_euid) {    /* if running suidperl */
2062 #ifdef HAS_SETEUID
2063             (void)seteuid(PL_uid);              /* musn't stay setuid root */
2064 #else
2065 #ifdef HAS_SETREUID
2066             (void)setreuid((Uid_t)-1, PL_uid);
2067 #else
2068 #ifdef HAS_SETRESUID
2069             (void)setresuid((Uid_t)-1, PL_uid, (Uid_t)-1);
2070 #else
2071             PerlProc_setuid(PL_uid);
2072 #endif
2073 #endif
2074 #endif
2075             if (PerlProc_geteuid() != PL_uid)
2076                 croak("Can't do seteuid!\n");
2077         }
2078 #endif /* IAMSUID */
2079         PL_rsfp = PerlProc_popen(SvPVX(cmd), "r");
2080         SvREFCNT_dec(cmd);
2081         SvREFCNT_dec(cpp);
2082     }
2083     else if (!*scriptname) {
2084         forbid_setid("program input from stdin");
2085         PL_rsfp = PerlIO_stdin();
2086     }
2087     else {
2088         PL_rsfp = PerlIO_open(scriptname,PERL_SCRIPT_MODE);
2089 #if defined(HAS_FCNTL) && defined(F_SETFD)
2090         if (PL_rsfp)
2091             fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,1);  /* ensure close-on-exec */
2092 #endif
2093     }
2094     if (!PL_rsfp) {
2095 #ifdef DOSUID
2096 #ifndef IAMSUID         /* in case script is not readable before setuid */
2097         if (PL_euid &&
2098             PerlLIO_stat(SvPVX(GvSV(PL_curcop->cop_filegv)),&PL_statbuf) >= 0 &&
2099             PL_statbuf.st_mode & (S_ISUID|S_ISGID))
2100         {
2101             /* try again */
2102             PerlProc_execv(form("%s/sperl%s", BIN_EXP, PL_patchlevel), PL_origargv);
2103             croak("Can't do setuid\n");
2104         }
2105 #endif
2106 #endif
2107         croak("Can't open perl script \"%s\": %s\n",
2108           SvPVX(GvSV(PL_curcop->cop_filegv)), Strerror(errno));
2109     }
2110 }
2111
2112 STATIC void
2113 validate_suid(char *validarg, char *scriptname, int fdscript)
2114 {
2115     int which;
2116
2117     /* do we need to emulate setuid on scripts? */
2118
2119     /* This code is for those BSD systems that have setuid #! scripts disabled
2120      * in the kernel because of a security problem.  Merely defining DOSUID
2121      * in perl will not fix that problem, but if you have disabled setuid
2122      * scripts in the kernel, this will attempt to emulate setuid and setgid
2123      * on scripts that have those now-otherwise-useless bits set.  The setuid
2124      * root version must be called suidperl or sperlN.NNN.  If regular perl
2125      * discovers that it has opened a setuid script, it calls suidperl with
2126      * the same argv that it had.  If suidperl finds that the script it has
2127      * just opened is NOT setuid root, it sets the effective uid back to the
2128      * uid.  We don't just make perl setuid root because that loses the
2129      * effective uid we had before invoking perl, if it was different from the
2130      * uid.
2131      *
2132      * DOSUID must be defined in both perl and suidperl, and IAMSUID must
2133      * be defined in suidperl only.  suidperl must be setuid root.  The
2134      * Configure script will set this up for you if you want it.
2135      */
2136
2137 #ifdef DOSUID
2138     dTHR;
2139     char *s, *s2;
2140
2141     if (PerlLIO_fstat(PerlIO_fileno(PL_rsfp),&PL_statbuf) < 0)  /* normal stat is insecure */
2142         croak("Can't stat script \"%s\"",PL_origfilename);
2143     if (fdscript < 0 && PL_statbuf.st_mode & (S_ISUID|S_ISGID)) {
2144         I32 len;
2145         STRLEN n_a;
2146
2147 #ifdef IAMSUID
2148 #ifndef HAS_SETREUID
2149         /* On this access check to make sure the directories are readable,
2150          * there is actually a small window that the user could use to make
2151          * filename point to an accessible directory.  So there is a faint
2152          * chance that someone could execute a setuid script down in a
2153          * non-accessible directory.  I don't know what to do about that.
2154          * But I don't think it's too important.  The manual lies when
2155          * it says access() is useful in setuid programs.
2156          */
2157         if (PerlLIO_access(SvPVX(GvSV(PL_curcop->cop_filegv)),1)) /*double check*/
2158             croak("Permission denied");
2159 #else
2160         /* If we can swap euid and uid, then we can determine access rights
2161          * with a simple stat of the file, and then compare device and
2162          * inode to make sure we did stat() on the same file we opened.
2163          * Then we just have to make sure he or she can execute it.
2164          */
2165         {
2166             struct stat tmpstatbuf;
2167
2168             if (
2169 #ifdef HAS_SETREUID
2170                 setreuid(PL_euid,PL_uid) < 0
2171 #else
2172 # if HAS_SETRESUID
2173                 setresuid(PL_euid,PL_uid,(Uid_t)-1) < 0
2174 # endif
2175 #endif
2176                 || PerlProc_getuid() != PL_euid || PerlProc_geteuid() != PL_uid)
2177                 croak("Can't swap uid and euid");       /* really paranoid */
2178             if (PerlLIO_stat(SvPVX(GvSV(PL_curcop->cop_filegv)),&tmpstatbuf) < 0)
2179                 croak("Permission denied");     /* testing full pathname here */
2180             if (tmpstatbuf.st_dev != PL_statbuf.st_dev ||
2181                 tmpstatbuf.st_ino != PL_statbuf.st_ino) {
2182                 (void)PerlIO_close(PL_rsfp);
2183                 if (PL_rsfp = PerlProc_popen("/bin/mail root","w")) {   /* heh, heh */
2184                     PerlIO_printf(PL_rsfp,
2185 "User %ld tried to run dev %ld ino %ld in place of dev %ld ino %ld!\n\
2186 (Filename of set-id script was %s, uid %ld gid %ld.)\n\nSincerely,\nperl\n",
2187                         (long)PL_uid,(long)tmpstatbuf.st_dev, (long)tmpstatbuf.st_ino,
2188                         (long)PL_statbuf.st_dev, (long)PL_statbuf.st_ino,
2189                         SvPVX(GvSV(PL_curcop->cop_filegv)),
2190                         (long)PL_statbuf.st_uid, (long)PL_statbuf.st_gid);
2191                     (void)PerlProc_pclose(PL_rsfp);
2192                 }
2193                 croak("Permission denied\n");
2194             }
2195             if (
2196 #ifdef HAS_SETREUID
2197               setreuid(PL_uid,PL_euid) < 0
2198 #else
2199 # if defined(HAS_SETRESUID)
2200               setresuid(PL_uid,PL_euid,(Uid_t)-1) < 0
2201 # endif
2202 #endif
2203               || PerlProc_getuid() != PL_uid || PerlProc_geteuid() != PL_euid)
2204                 croak("Can't reswap uid and euid");
2205             if (!cando(S_IXUSR,FALSE,&PL_statbuf))              /* can real uid exec? */
2206                 croak("Permission denied\n");
2207         }
2208 #endif /* HAS_SETREUID */
2209 #endif /* IAMSUID */
2210
2211         if (!S_ISREG(PL_statbuf.st_mode))
2212             croak("Permission denied");
2213         if (PL_statbuf.st_mode & S_IWOTH)
2214             croak("Setuid/gid script is writable by world");
2215         PL_doswitches = FALSE;          /* -s is insecure in suid */
2216         PL_curcop->cop_line++;
2217         if (sv_gets(PL_linestr, PL_rsfp, 0) == Nullch ||
2218           strnNE(SvPV(PL_linestr,n_a),"#!",2) ) /* required even on Sys V */
2219             croak("No #! line");
2220         s = SvPV(PL_linestr,n_a)+2;
2221         if (*s == ' ') s++;
2222         while (!isSPACE(*s)) s++;
2223         for (s2 = s;  (s2 > SvPV(PL_linestr,n_a)+2 &&
2224                        (isDIGIT(s2[-1]) || strchr("._-", s2[-1])));  s2--) ;
2225         if (strnNE(s2-4,"perl",4) && strnNE(s-9,"perl",4))  /* sanity check */
2226             croak("Not a perl script");
2227         while (*s == ' ' || *s == '\t') s++;
2228         /*
2229          * #! arg must be what we saw above.  They can invoke it by
2230          * mentioning suidperl explicitly, but they may not add any strange
2231          * arguments beyond what #! says if they do invoke suidperl that way.
2232          */
2233         len = strlen(validarg);
2234         if (strEQ(validarg," PHOOEY ") ||
2235             strnNE(s,validarg,len) || !isSPACE(s[len]))
2236             croak("Args must match #! line");
2237
2238 #ifndef IAMSUID
2239         if (PL_euid != PL_uid && (PL_statbuf.st_mode & S_ISUID) &&
2240             PL_euid == PL_statbuf.st_uid)
2241             if (!PL_do_undump)
2242                 croak("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
2243 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
2244 #endif /* IAMSUID */
2245
2246         if (PL_euid) {  /* oops, we're not the setuid root perl */
2247             (void)PerlIO_close(PL_rsfp);
2248 #ifndef IAMSUID
2249             /* try again */
2250             PerlProc_execv(form("%s/sperl%s", BIN_EXP, PL_patchlevel), PL_origargv);
2251 #endif
2252             croak("Can't do setuid\n");
2253         }
2254
2255         if (PL_statbuf.st_mode & S_ISGID && PL_statbuf.st_gid != PL_egid) {
2256 #ifdef HAS_SETEGID
2257             (void)setegid(PL_statbuf.st_gid);
2258 #else
2259 #ifdef HAS_SETREGID
2260            (void)setregid((Gid_t)-1,PL_statbuf.st_gid);
2261 #else
2262 #ifdef HAS_SETRESGID
2263            (void)setresgid((Gid_t)-1,PL_statbuf.st_gid,(Gid_t)-1);
2264 #else
2265             PerlProc_setgid(PL_statbuf.st_gid);
2266 #endif
2267 #endif
2268 #endif
2269             if (PerlProc_getegid() != PL_statbuf.st_gid)
2270                 croak("Can't do setegid!\n");
2271         }
2272         if (PL_statbuf.st_mode & S_ISUID) {
2273             if (PL_statbuf.st_uid != PL_euid)
2274 #ifdef HAS_SETEUID
2275                 (void)seteuid(PL_statbuf.st_uid);       /* all that for this */
2276 #else
2277 #ifdef HAS_SETREUID
2278                 (void)setreuid((Uid_t)-1,PL_statbuf.st_uid);
2279 #else
2280 #ifdef HAS_SETRESUID
2281                 (void)setresuid((Uid_t)-1,PL_statbuf.st_uid,(Uid_t)-1);
2282 #else
2283                 PerlProc_setuid(PL_statbuf.st_uid);
2284 #endif
2285 #endif
2286 #endif
2287             if (PerlProc_geteuid() != PL_statbuf.st_uid)
2288                 croak("Can't do seteuid!\n");
2289         }
2290         else if (PL_uid) {                      /* oops, mustn't run as root */
2291 #ifdef HAS_SETEUID
2292           (void)seteuid((Uid_t)PL_uid);
2293 #else
2294 #ifdef HAS_SETREUID
2295           (void)setreuid((Uid_t)-1,(Uid_t)PL_uid);
2296 #else
2297 #ifdef HAS_SETRESUID
2298           (void)setresuid((Uid_t)-1,(Uid_t)PL_uid,(Uid_t)-1);
2299 #else
2300           PerlProc_setuid((Uid_t)PL_uid);
2301 #endif
2302 #endif
2303 #endif
2304             if (PerlProc_geteuid() != PL_uid)
2305                 croak("Can't do seteuid!\n");
2306         }
2307         init_ids();
2308         if (!cando(S_IXUSR,TRUE,&PL_statbuf))
2309             croak("Permission denied\n");       /* they can't do this */
2310     }
2311 #ifdef IAMSUID
2312     else if (PL_preprocess)
2313         croak("-P not allowed for setuid/setgid script\n");
2314     else if (fdscript >= 0)
2315         croak("fd script not allowed in suidperl\n");
2316     else
2317         croak("Script is not setuid/setgid in suidperl\n");
2318
2319     /* We absolutely must clear out any saved ids here, so we */
2320     /* exec the real perl, substituting fd script for scriptname. */
2321     /* (We pass script name as "subdir" of fd, which perl will grok.) */
2322     PerlIO_rewind(PL_rsfp);
2323     PerlLIO_lseek(PerlIO_fileno(PL_rsfp),(Off_t)0,0);  /* just in case rewind didn't */
2324     for (which = 1; PL_origargv[which] && PL_origargv[which] != scriptname; which++) ;
2325     if (!PL_origargv[which])
2326         croak("Permission denied");
2327     PL_origargv[which] = savepv(form("/dev/fd/%d/%s",
2328                                   PerlIO_fileno(PL_rsfp), PL_origargv[which]));
2329 #if defined(HAS_FCNTL) && defined(F_SETFD)
2330     fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,0);    /* ensure no close-on-exec */
2331 #endif
2332     PerlProc_execv(form("%s/perl%s", BIN_EXP, PL_patchlevel), PL_origargv);/* try again */
2333     croak("Can't do setuid\n");
2334 #endif /* IAMSUID */
2335 #else /* !DOSUID */
2336     if (PL_euid != PL_uid || PL_egid != PL_gid) {       /* (suidperl doesn't exist, in fact) */
2337 #ifndef SETUID_SCRIPTS_ARE_SECURE_NOW
2338         dTHR;
2339         PerlLIO_fstat(PerlIO_fileno(PL_rsfp),&PL_statbuf);      /* may be either wrapped or real suid */
2340         if ((PL_euid != PL_uid && PL_euid == PL_statbuf.st_uid && PL_statbuf.st_mode & S_ISUID)
2341             ||
2342             (PL_egid != PL_gid && PL_egid == PL_statbuf.st_gid && PL_statbuf.st_mode & S_ISGID)
2343            )
2344             if (!PL_do_undump)
2345                 croak("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
2346 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
2347 #endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
2348         /* not set-id, must be wrapped */
2349     }
2350 #endif /* DOSUID */
2351 }
2352
2353 STATIC void
2354 find_beginning(void)
2355 {
2356     register char *s, *s2;
2357
2358     /* skip forward in input to the real script? */
2359
2360     forbid_setid("-x");
2361     while (PL_doextract) {
2362         if ((s = sv_gets(PL_linestr, PL_rsfp, 0)) == Nullch)
2363             croak("No Perl script found in input\n");
2364         if (*s == '#' && s[1] == '!' && (s = instr(s,"perl"))) {
2365             PerlIO_ungetc(PL_rsfp, '\n');               /* to keep line count right */
2366             PL_doextract = FALSE;
2367             while (*s && !(isSPACE (*s) || *s == '#')) s++;
2368             s2 = s;
2369             while (*s == ' ' || *s == '\t') s++;
2370             if (*s++ == '-') {
2371                 while (isDIGIT(s2[-1]) || strchr("-._", s2[-1])) s2--;
2372                 if (strnEQ(s2-4,"perl",4))
2373                     /*SUPPRESS 530*/
2374                     while (s = moreswitches(s)) ;
2375             }
2376             if (PL_cddir && PerlDir_chdir(PL_cddir) < 0)
2377                 croak("Can't chdir to %s",PL_cddir);
2378         }
2379     }
2380 }
2381
2382
2383 STATIC void
2384 init_ids(void)
2385 {
2386     PL_uid = (int)PerlProc_getuid();
2387     PL_euid = (int)PerlProc_geteuid();
2388     PL_gid = (int)PerlProc_getgid();
2389     PL_egid = (int)PerlProc_getegid();
2390 #ifdef VMS
2391     PL_uid |= PL_gid << 16;
2392     PL_euid |= PL_egid << 16;
2393 #endif
2394     PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2395 }
2396
2397 STATIC void
2398 forbid_setid(char *s)
2399 {
2400     if (PL_euid != PL_uid)
2401         croak("No %s allowed while running setuid", s);
2402     if (PL_egid != PL_gid)
2403         croak("No %s allowed while running setgid", s);
2404 }
2405
2406 STATIC void
2407 init_debugger(void)
2408 {
2409     dTHR;
2410     PL_curstash = PL_debstash;
2411     PL_dbargs = GvAV(gv_AVadd((gv_fetchpv("args", GV_ADDMULTI, SVt_PVAV))));
2412     AvREAL_off(PL_dbargs);
2413     PL_DBgv = gv_fetchpv("DB", GV_ADDMULTI, SVt_PVGV);
2414     PL_DBline = gv_fetchpv("dbline", GV_ADDMULTI, SVt_PVAV);
2415     PL_DBsub = gv_HVadd(gv_fetchpv("sub", GV_ADDMULTI, SVt_PVHV));
2416     PL_DBsingle = GvSV((gv_fetchpv("single", GV_ADDMULTI, SVt_PV)));
2417     sv_setiv(PL_DBsingle, 0);
2418     PL_DBtrace = GvSV((gv_fetchpv("trace", GV_ADDMULTI, SVt_PV)));
2419     sv_setiv(PL_DBtrace, 0);
2420     PL_DBsignal = GvSV((gv_fetchpv("signal", GV_ADDMULTI, SVt_PV)));
2421     sv_setiv(PL_DBsignal, 0);
2422     PL_curstash = PL_defstash;
2423 }
2424
2425 #ifndef STRESS_REALLOC
2426 #define REASONABLE(size) (size)
2427 #else
2428 #define REASONABLE(size) (1) /* unreasonable */
2429 #endif
2430
2431 void
2432 init_stacks(ARGSproto)
2433 {
2434     /* start with 128-item stack and 8K cxstack */
2435     PL_curstackinfo = new_stackinfo(REASONABLE(128),
2436                                  REASONABLE(8192/sizeof(PERL_CONTEXT) - 1));
2437     PL_curstackinfo->si_type = PERLSI_MAIN;
2438     PL_curstack = PL_curstackinfo->si_stack;
2439     PL_mainstack = PL_curstack;         /* remember in case we switch stacks */
2440
2441     PL_stack_base = AvARRAY(PL_curstack);
2442     PL_stack_sp = PL_stack_base;
2443     PL_stack_max = PL_stack_base + AvMAX(PL_curstack);
2444
2445     New(50,PL_tmps_stack,REASONABLE(128),SV*);
2446     PL_tmps_floor = -1;
2447     PL_tmps_ix = -1;
2448     PL_tmps_max = REASONABLE(128);
2449
2450     New(54,PL_markstack,REASONABLE(32),I32);
2451     PL_markstack_ptr = PL_markstack;
2452     PL_markstack_max = PL_markstack + REASONABLE(32);
2453
2454     SET_MARKBASE;
2455
2456     New(54,PL_scopestack,REASONABLE(32),I32);
2457     PL_scopestack_ix = 0;
2458     PL_scopestack_max = REASONABLE(32);
2459
2460     New(54,PL_savestack,REASONABLE(128),ANY);
2461     PL_savestack_ix = 0;
2462     PL_savestack_max = REASONABLE(128);
2463
2464     New(54,PL_retstack,REASONABLE(16),OP*);
2465     PL_retstack_ix = 0;
2466     PL_retstack_max = REASONABLE(16);
2467 }
2468
2469 #undef REASONABLE
2470
2471 STATIC void
2472 nuke_stacks(void)
2473 {
2474     dTHR;
2475     while (PL_curstackinfo->si_next)
2476         PL_curstackinfo = PL_curstackinfo->si_next;
2477     while (PL_curstackinfo) {
2478         PERL_SI *p = PL_curstackinfo->si_prev;
2479         /* curstackinfo->si_stack got nuked by sv_free_arenas() */
2480         Safefree(PL_curstackinfo->si_cxstack);
2481         Safefree(PL_curstackinfo);
2482         PL_curstackinfo = p;
2483     }
2484     Safefree(PL_tmps_stack);
2485     Safefree(PL_markstack);
2486     Safefree(PL_scopestack);
2487     Safefree(PL_savestack);
2488     Safefree(PL_retstack);
2489     DEBUG( {
2490         Safefree(PL_debname);
2491         Safefree(PL_debdelim);
2492     } )
2493 }
2494
2495 #ifndef PERL_OBJECT
2496 static PerlIO *tmpfp;  /* moved outside init_lexer() because of UNICOS bug */
2497 #endif
2498
2499 STATIC void
2500 init_lexer(void)
2501 {
2502 #ifdef PERL_OBJECT
2503         PerlIO *tmpfp;
2504 #endif
2505     tmpfp = PL_rsfp;
2506     PL_rsfp = Nullfp;
2507     lex_start(PL_linestr);
2508     PL_rsfp = tmpfp;
2509     PL_subname = newSVpv("main",4);
2510 }
2511
2512 STATIC void
2513 init_predump_symbols(void)
2514 {
2515     dTHR;
2516     GV *tmpgv;
2517     GV *othergv;
2518
2519     sv_setpvn(perl_get_sv("\"", TRUE), " ", 1);
2520     PL_stdingv = gv_fetchpv("STDIN",TRUE, SVt_PVIO);
2521     GvMULTI_on(PL_stdingv);
2522     IoIFP(GvIOp(PL_stdingv)) = PerlIO_stdin();
2523     tmpgv = gv_fetchpv("stdin",TRUE, SVt_PV);
2524     GvMULTI_on(tmpgv);
2525     GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(PL_stdingv));
2526
2527     tmpgv = gv_fetchpv("STDOUT",TRUE, SVt_PVIO);
2528     GvMULTI_on(tmpgv);
2529     IoOFP(GvIOp(tmpgv)) = IoIFP(GvIOp(tmpgv)) = PerlIO_stdout();
2530     setdefout(tmpgv);
2531     tmpgv = gv_fetchpv("stdout",TRUE, SVt_PV);
2532     GvMULTI_on(tmpgv);
2533     GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(PL_defoutgv));
2534
2535     othergv = gv_fetchpv("STDERR",TRUE, SVt_PVIO);
2536     GvMULTI_on(othergv);
2537     IoOFP(GvIOp(othergv)) = IoIFP(GvIOp(othergv)) = PerlIO_stderr();
2538     tmpgv = gv_fetchpv("stderr",TRUE, SVt_PV);
2539     GvMULTI_on(tmpgv);
2540     GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(othergv));
2541
2542     PL_statname = NEWSV(66,0);          /* last filename we did stat on */
2543
2544     if (!PL_osname)
2545         PL_osname = savepv(OSNAME);
2546 }
2547
2548 STATIC void
2549 init_postdump_symbols(register int argc, register char **argv, register char **env)
2550 {
2551     dTHR;
2552     char *s;
2553     SV *sv;
2554     GV* tmpgv;
2555
2556     argc--,argv++;      /* skip name of script */
2557     if (PL_doswitches) {
2558         for (; argc > 0 && **argv == '-'; argc--,argv++) {
2559             if (!argv[0][1])
2560                 break;
2561             if (argv[0][1] == '-') {
2562                 argc--,argv++;
2563                 break;
2564             }
2565             if (s = strchr(argv[0], '=')) {
2566                 *s++ = '\0';
2567                 sv_setpv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),s);
2568             }
2569             else
2570                 sv_setiv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),1);
2571         }
2572     }
2573     PL_toptarget = NEWSV(0,0);
2574     sv_upgrade(PL_toptarget, SVt_PVFM);
2575     sv_setpvn(PL_toptarget, "", 0);
2576     PL_bodytarget = NEWSV(0,0);
2577     sv_upgrade(PL_bodytarget, SVt_PVFM);
2578     sv_setpvn(PL_bodytarget, "", 0);
2579     PL_formtarget = PL_bodytarget;
2580
2581     TAINT;
2582     if (tmpgv = gv_fetchpv("0",TRUE, SVt_PV)) {
2583         sv_setpv(GvSV(tmpgv),PL_origfilename);
2584         magicname("0", "0", 1);
2585     }
2586     if (tmpgv = gv_fetchpv("\030",TRUE, SVt_PV))
2587         sv_setpv(GvSV(tmpgv),PL_origargv[0]);
2588     if (PL_argvgv = gv_fetchpv("ARGV",TRUE, SVt_PVAV)) {
2589         GvMULTI_on(PL_argvgv);
2590         (void)gv_AVadd(PL_argvgv);
2591         av_clear(GvAVn(PL_argvgv));
2592         for (; argc > 0; argc--,argv++) {
2593             av_push(GvAVn(PL_argvgv),newSVpv(argv[0],0));
2594         }
2595     }
2596     if (PL_envgv = gv_fetchpv("ENV",TRUE, SVt_PVHV)) {
2597         HV *hv;
2598         GvMULTI_on(PL_envgv);
2599         hv = GvHVn(PL_envgv);
2600         hv_magic(hv, PL_envgv, 'E');
2601 #ifndef VMS  /* VMS doesn't have environ array */
2602         /* Note that if the supplied env parameter is actually a copy
2603            of the global environ then it may now point to free'd memory
2604            if the environment has been modified since. To avoid this
2605            problem we treat env==NULL as meaning 'use the default'
2606         */
2607         if (!env)
2608             env = environ;
2609         if (env != environ)
2610             environ[0] = Nullch;
2611         for (; *env; env++) {
2612             if (!(s = strchr(*env,'=')))
2613                 continue;
2614             *s++ = '\0';
2615 #if defined(MSDOS)
2616             (void)strupr(*env);
2617 #endif
2618             sv = newSVpv(s--,0);
2619             (void)hv_store(hv, *env, s - *env, sv, 0);
2620             *s = '=';
2621 #if defined(__BORLANDC__) && defined(USE_WIN32_RTL_ENV)
2622             /* Sins of the RTL. See note in my_setenv(). */
2623             (void)PerlEnv_putenv(savepv(*env));
2624 #endif
2625         }
2626 #endif
2627 #ifdef DYNAMIC_ENV_FETCH
2628         HvNAME(hv) = savepv(ENV_HV_NAME);
2629 #endif
2630     }
2631     TAINT_NOT;
2632     if (tmpgv = gv_fetchpv("$",TRUE, SVt_PV))
2633         sv_setiv(GvSV(tmpgv), (IV)getpid());
2634 }
2635
2636 STATIC void
2637 init_perllib(void)
2638 {
2639     char *s;
2640     if (!PL_tainting) {
2641 #ifndef VMS
2642         s = PerlEnv_getenv("PERL5LIB");
2643         if (s)
2644             incpush(s, TRUE);
2645         else
2646             incpush(PerlEnv_getenv("PERLLIB"), FALSE);
2647 #else /* VMS */
2648         /* Treat PERL5?LIB as a possible search list logical name -- the
2649          * "natural" VMS idiom for a Unix path string.  We allow each
2650          * element to be a set of |-separated directories for compatibility.
2651          */
2652         char buf[256];
2653         int idx = 0;
2654         if (my_trnlnm("PERL5LIB",buf,0))
2655             do { incpush(buf,TRUE); } while (my_trnlnm("PERL5LIB",buf,++idx));
2656         else
2657             while (my_trnlnm("PERLLIB",buf,idx++)) incpush(buf,FALSE);
2658 #endif /* VMS */
2659     }
2660
2661 /* Use the ~-expanded versions of APPLLIB (undocumented),
2662     ARCHLIB PRIVLIB SITEARCH and SITELIB
2663 */
2664 #ifdef APPLLIB_EXP
2665     incpush(APPLLIB_EXP, TRUE);
2666 #endif
2667
2668 #ifdef ARCHLIB_EXP
2669     incpush(ARCHLIB_EXP, FALSE);
2670 #endif
2671 #ifndef PRIVLIB_EXP
2672 #define PRIVLIB_EXP "/usr/local/lib/perl5:/usr/local/lib/perl"
2673 #endif
2674 #if defined(WIN32)
2675     incpush(PRIVLIB_EXP, TRUE);
2676 #else
2677     incpush(PRIVLIB_EXP, FALSE);
2678 #endif
2679
2680 #ifdef SITEARCH_EXP
2681     incpush(SITEARCH_EXP, FALSE);
2682 #endif
2683 #ifdef SITELIB_EXP
2684 #if defined(WIN32)
2685     incpush(SITELIB_EXP, TRUE);
2686 #else
2687     incpush(SITELIB_EXP, FALSE);
2688 #endif
2689 #endif
2690     if (!PL_tainting)
2691         incpush(".", FALSE);
2692 }
2693
2694 #if defined(DOSISH)
2695 #    define PERLLIB_SEP ';'
2696 #else
2697 #  if defined(VMS)
2698 #    define PERLLIB_SEP '|'
2699 #  else
2700 #    define PERLLIB_SEP ':'
2701 #  endif
2702 #endif
2703 #ifndef PERLLIB_MANGLE
2704 #  define PERLLIB_MANGLE(s,n) (s)
2705 #endif
2706
2707 STATIC void
2708 incpush(char *p, int addsubdirs)
2709 {
2710     SV *subdir = Nullsv;
2711
2712     if (!p)
2713         return;
2714
2715     if (addsubdirs) {
2716         subdir = sv_newmortal();
2717         if (!PL_archpat_auto) {
2718             STRLEN len = (sizeof(ARCHNAME) + strlen(PL_patchlevel)
2719                           + sizeof("//auto"));
2720             New(55, PL_archpat_auto, len, char);
2721             sprintf(PL_archpat_auto, "/%s/%s/auto", ARCHNAME, PL_patchlevel);
2722 #ifdef VMS
2723         for (len = sizeof(ARCHNAME) + 2;
2724              PL_archpat_auto[len] != '\0' && PL_archpat_auto[len] != '/'; len++)
2725                 if (PL_archpat_auto[len] == '.') PL_archpat_auto[len] = '_';
2726 #endif
2727         }
2728     }
2729
2730     /* Break at all separators */
2731     while (p && *p) {
2732         SV *libdir = NEWSV(55,0);
2733         char *s;
2734
2735         /* skip any consecutive separators */
2736         while ( *p == PERLLIB_SEP ) {
2737             /* Uncomment the next line for PATH semantics */
2738             /* av_push(GvAVn(PL_incgv), newSVpv(".", 1)); */
2739             p++;
2740         }
2741
2742         if ( (s = strchr(p, PERLLIB_SEP)) != Nullch ) {
2743             sv_setpvn(libdir, PERLLIB_MANGLE(p, (STRLEN)(s - p)),
2744                       (STRLEN)(s - p));
2745             p = s + 1;
2746         }
2747         else {
2748             sv_setpv(libdir, PERLLIB_MANGLE(p, 0));
2749             p = Nullch; /* break out */
2750         }
2751
2752         /*
2753          * BEFORE pushing libdir onto @INC we may first push version- and
2754          * archname-specific sub-directories.
2755          */
2756         if (addsubdirs) {
2757             struct stat tmpstatbuf;
2758 #ifdef VMS
2759             char *unix;
2760             STRLEN len;
2761
2762             if ((unix = tounixspec_ts(SvPV(libdir,len),Nullch)) != Nullch) {
2763                 len = strlen(unix);
2764                 while (unix[len-1] == '/') len--;  /* Cosmetic */
2765                 sv_usepvn(libdir,unix,len);
2766             }
2767             else
2768                 PerlIO_printf(PerlIO_stderr(),
2769                               "Failed to unixify @INC element \"%s\"\n",
2770                               SvPV(libdir,len));
2771 #endif
2772             /* .../archname/version if -d .../archname/version/auto */
2773             sv_setsv(subdir, libdir);
2774             sv_catpv(subdir, PL_archpat_auto);
2775             if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
2776                   S_ISDIR(tmpstatbuf.st_mode))
2777                 av_push(GvAVn(PL_incgv),
2778                         newSVpv(SvPVX(subdir), SvCUR(subdir) - sizeof "auto"));
2779
2780             /* .../archname if -d .../archname/auto */
2781             sv_insert(subdir, SvCUR(libdir) + sizeof(ARCHNAME),
2782                       strlen(PL_patchlevel) + 1, "", 0);
2783             if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
2784                   S_ISDIR(tmpstatbuf.st_mode))
2785                 av_push(GvAVn(PL_incgv),
2786                         newSVpv(SvPVX(subdir), SvCUR(subdir) - sizeof "auto"));
2787         }
2788
2789         /* finally push this lib directory on the end of @INC */
2790         av_push(GvAVn(PL_incgv), libdir);
2791     }
2792 }
2793
2794 #ifdef USE_THREADS
2795 STATIC struct perl_thread *
2796 init_main_thread()
2797 {
2798     struct perl_thread *thr;
2799     XPV *xpv;
2800
2801     Newz(53, thr, 1, struct perl_thread);
2802     PL_curcop = &PL_compiling;
2803     thr->cvcache = newHV();
2804     thr->threadsv = newAV();
2805     /* thr->threadsvp is set when find_threadsv is called */
2806     thr->specific = newAV();
2807     thr->errhv = newHV();
2808     thr->flags = THRf_R_JOINABLE;
2809     MUTEX_INIT(&thr->mutex);
2810     /* Handcraft thrsv similarly to mess_sv */
2811     New(53, PL_thrsv, 1, SV);
2812     Newz(53, xpv, 1, XPV);
2813     SvFLAGS(PL_thrsv) = SVt_PV;
2814     SvANY(PL_thrsv) = (void*)xpv;
2815     SvREFCNT(PL_thrsv) = 1 << 30;       /* practically infinite */
2816     SvPVX(PL_thrsv) = (char*)thr;
2817     SvCUR_set(PL_thrsv, sizeof(thr));
2818     SvLEN_set(PL_thrsv, sizeof(thr));
2819     *SvEND(PL_thrsv) = '\0';    /* in the trailing_nul field */
2820     thr->oursv = PL_thrsv;
2821     PL_chopset = " \n-";
2822     PL_dumpindent = 4;
2823
2824     MUTEX_LOCK(&PL_threads_mutex);
2825     PL_nthreads++;
2826     thr->tid = 0;
2827     thr->next = thr;
2828     thr->prev = thr;
2829     MUTEX_UNLOCK(&PL_threads_mutex);
2830
2831 #ifdef HAVE_THREAD_INTERN
2832     init_thread_intern(thr);
2833 #endif
2834
2835 #ifdef SET_THREAD_SELF
2836     SET_THREAD_SELF(thr);
2837 #else
2838     thr->self = pthread_self();
2839 #endif /* SET_THREAD_SELF */
2840     SET_THR(thr);
2841
2842     /*
2843      * These must come after the SET_THR because sv_setpvn does
2844      * SvTAINT and the taint fields require dTHR.
2845      */
2846     PL_toptarget = NEWSV(0,0);
2847     sv_upgrade(PL_toptarget, SVt_PVFM);
2848     sv_setpvn(PL_toptarget, "", 0);
2849     PL_bodytarget = NEWSV(0,0);
2850     sv_upgrade(PL_bodytarget, SVt_PVFM);
2851     sv_setpvn(PL_bodytarget, "", 0);
2852     PL_formtarget = PL_bodytarget;
2853     thr->errsv = newSVpv("", 0);
2854     (void) find_threadsv("@");  /* Ensure $@ is initialised early */
2855
2856     PL_maxscream = -1;
2857     PL_regcompp = FUNC_NAME_TO_PTR(pregcomp);
2858     PL_regexecp = FUNC_NAME_TO_PTR(regexec_flags);
2859     PL_regindent = 0;
2860     PL_reginterp_cnt = 0;
2861
2862     return thr;
2863 }
2864 #endif /* USE_THREADS */
2865
2866 void
2867 call_list(I32 oldscope, AV *paramList)
2868 {
2869     dTHR;
2870     line_t oldline = PL_curcop->cop_line;
2871     STRLEN len;
2872     dJMPENV;
2873     int ret;
2874
2875     while (AvFILL(paramList) >= 0) {
2876         CV *cv = (CV*)av_shift(paramList);
2877
2878         SAVEFREESV(cv);
2879
2880         JMPENV_PUSH(ret);
2881         switch (ret) {
2882         case 0: {
2883                 SV* atsv = ERRSV;
2884                 PUSHMARK(PL_stack_sp);
2885                 perl_call_sv((SV*)cv, G_EVAL|G_DISCARD);
2886                 (void)SvPV(atsv, len);
2887                 if (len) {
2888                     JMPENV_POP;
2889                     PL_curcop = &PL_compiling;
2890                     PL_curcop->cop_line = oldline;
2891                     if (paramList == PL_beginav)
2892                         sv_catpv(atsv, "BEGIN failed--compilation aborted");
2893                     else
2894                         sv_catpv(atsv, "END failed--cleanup aborted");
2895                     while (PL_scopestack_ix > oldscope)
2896                         LEAVE;
2897                     croak("%s", SvPVX(atsv));
2898                 }
2899             }
2900             break;
2901         case 1:
2902             STATUS_ALL_FAILURE;
2903             /* FALL THROUGH */
2904         case 2:
2905             /* my_exit() was called */
2906             while (PL_scopestack_ix > oldscope)
2907                 LEAVE;
2908             FREETMPS;
2909             PL_curstash = PL_defstash;
2910             if (PL_endav)
2911                 call_list(oldscope, PL_endav);
2912             JMPENV_POP;
2913             PL_curcop = &PL_compiling;
2914             PL_curcop->cop_line = oldline;
2915             if (PL_statusvalue) {
2916                 if (paramList == PL_beginav)
2917                     croak("BEGIN failed--compilation aborted");
2918                 else
2919                     croak("END failed--cleanup aborted");
2920             }
2921             my_exit_jump();
2922             /* NOTREACHED */
2923         case 3:
2924             if (!PL_restartop) {
2925                 PerlIO_printf(PerlIO_stderr(), "panic: restartop\n");
2926                 FREETMPS;
2927                 break;
2928             }
2929             JMPENV_POP;
2930             PL_curcop = &PL_compiling;
2931             PL_curcop->cop_line = oldline;
2932             JMPENV_JUMP(3);
2933         }
2934         JMPENV_POP;
2935     }
2936 }
2937
2938 void
2939 my_exit(U32 status)
2940 {
2941     dTHR;
2942
2943     DEBUG_S(PerlIO_printf(Perl_debug_log, "my_exit: thread %p, status %lu\n",
2944                           thr, (unsigned long) status));
2945     switch (status) {
2946     case 0:
2947         STATUS_ALL_SUCCESS;
2948         break;
2949     case 1:
2950         STATUS_ALL_FAILURE;
2951         break;
2952     default:
2953         STATUS_NATIVE_SET(status);
2954         break;
2955     }
2956     my_exit_jump();
2957 }
2958
2959 void
2960 my_failure_exit(void)
2961 {
2962 #ifdef VMS
2963     if (vaxc$errno & 1) {
2964         if (STATUS_NATIVE & 1)          /* fortuitiously includes "-1" */
2965             STATUS_NATIVE_SET(44);
2966     }
2967     else {
2968         if (!vaxc$errno && errno)       /* unlikely */
2969             STATUS_NATIVE_SET(44);
2970         else
2971             STATUS_NATIVE_SET(vaxc$errno);
2972     }
2973 #else
2974     int exitstatus;
2975     if (errno & 255)
2976         STATUS_POSIX_SET(errno);
2977     else {
2978         exitstatus = STATUS_POSIX >> 8;
2979         if (exitstatus & 255)
2980             STATUS_POSIX_SET(exitstatus);
2981         else
2982             STATUS_POSIX_SET(255);
2983     }
2984 #endif
2985     my_exit_jump();
2986 }
2987
2988 STATIC void
2989 my_exit_jump(void)
2990 {
2991     dTHR;
2992     register PERL_CONTEXT *cx;
2993     I32 gimme;
2994     SV **newsp;
2995
2996     if (PL_e_script) {
2997         SvREFCNT_dec(PL_e_script);
2998         PL_e_script = Nullsv;
2999     }
3000
3001     POPSTACK_TO(PL_mainstack);
3002     if (cxstack_ix >= 0) {
3003         if (cxstack_ix > 0)
3004             dounwind(0);
3005         POPBLOCK(cx,PL_curpm);
3006         LEAVE;
3007     }
3008
3009     JMPENV_JUMP(2);
3010 }
3011
3012 #ifdef PERL_OBJECT
3013 #define NO_XSLOCKS
3014 #endif  /* PERL_OBJECT */
3015
3016 #include "XSUB.h"
3017
3018 static I32
3019 #ifdef PERL_OBJECT
3020 read_e_script(CPerlObj *pPerl, int idx, SV *buf_sv, int maxlen)
3021 #else
3022 read_e_script(int idx, SV *buf_sv, int maxlen)
3023 #endif
3024 {
3025     char *p, *nl;
3026     p  = SvPVX(PL_e_script);
3027     nl = strchr(p, '\n');
3028     nl = (nl) ? nl+1 : SvEND(PL_e_script);
3029     if (nl-p == 0) {
3030         filter_del(read_e_script);
3031         return 0;
3032     }
3033     sv_catpvn(buf_sv, p, nl-p);
3034     sv_chop(PL_e_script, nl);
3035     return 1;
3036 }
3037
3038