perl.c

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