perl.c

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