perl.c

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