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