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