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