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