contrib/perl5/perl.c

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