3 * Copyright (c) 1987-2000 Larry Wall
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.
11 * "A ship then new they built for him/of mithril and of elven glass" --Bilbo
15 #define PERL_IN_PERL_C
17 #include "patchlevel.h" /* for local_patches */
19 /* XXX If this causes problems, set i_unistd=undef in the hint file. */
24 #if !defined(STANDARD_C) && !defined(HAS_GETENV_PROTOTYPE)
25 char *getenv (char *); /* Usually in <stdlib.h> */
28 static I32 read_e_script(pTHXo_ int idx, SV *buf_sv, int maxlen);
43 #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
50 #define perl_construct Perl_construct
51 #define perl_parse Perl_parse
52 #define perl_run Perl_run
53 #define perl_destruct Perl_destruct
54 #define perl_free Perl_free
57 #ifdef PERL_IMPLICIT_SYS
59 perl_alloc_using(struct IPerlMem* ipM, struct IPerlMem* ipMS,
60 struct IPerlMem* ipMP, struct IPerlEnv* ipE,
61 struct IPerlStdIO* ipStd, struct IPerlLIO* ipLIO,
62 struct IPerlDir* ipD, struct IPerlSock* ipS,
63 struct IPerlProc* ipP)
65 PerlInterpreter *my_perl;
67 my_perl = (PerlInterpreter*)new(ipM) CPerlObj(ipM, ipMS, ipMP, ipE, ipStd,
68 ipLIO, ipD, ipS, ipP);
69 PERL_SET_INTERP(my_perl);
71 /* New() needs interpreter, so call malloc() instead */
72 my_perl = (PerlInterpreter*)(*ipM->pMalloc)(ipM, sizeof(PerlInterpreter));
73 PERL_SET_INTERP(my_perl);
74 Zero(my_perl, 1, PerlInterpreter);
91 =for apidoc perl_alloc
93 Allocates a new Perl interpreter. See L<perlembed>.
101 PerlInterpreter *my_perl;
103 /* New() needs interpreter, so call malloc() instead */
104 my_perl = (PerlInterpreter*)PerlMem_malloc(sizeof(PerlInterpreter));
105 PERL_SET_INTERP(my_perl);
106 Zero(my_perl, 1, PerlInterpreter);
109 #endif /* PERL_IMPLICIT_SYS */
112 =for apidoc perl_construct
114 Initializes a new Perl interpreter. See L<perlembed>.
120 perl_construct(pTHXx)
125 struct perl_thread *thr = NULL;
126 #endif /* FAKE_THREADS */
127 #endif /* USE_THREADS */
131 PL_perl_destruct_level = 1;
133 if (PL_perl_destruct_level > 0)
137 /* Init the real globals (and main thread)? */
141 #ifdef ALLOC_THREAD_KEY
144 if (pthread_key_create(&PL_thr_key, 0))
145 Perl_croak(aTHX_ "panic: pthread_key_create");
147 MUTEX_INIT(&PL_sv_mutex);
149 * Safe to use basic SV functions from now on (though
150 * not things like mortals or tainting yet).
152 MUTEX_INIT(&PL_eval_mutex);
153 COND_INIT(&PL_eval_cond);
154 MUTEX_INIT(&PL_threads_mutex);
155 COND_INIT(&PL_nthreads_cond);
156 #ifdef EMULATE_ATOMIC_REFCOUNTS
157 MUTEX_INIT(&PL_svref_mutex);
158 #endif /* EMULATE_ATOMIC_REFCOUNTS */
160 MUTEX_INIT(&PL_cred_mutex);
162 thr = init_main_thread();
163 #endif /* USE_THREADS */
165 PL_protect = MEMBER_TO_FPTR(Perl_default_protect); /* for exceptions */
167 PL_curcop = &PL_compiling; /* needed by ckWARN, right away */
169 PL_linestr = NEWSV(65,79);
170 sv_upgrade(PL_linestr,SVt_PVIV);
172 if (!SvREADONLY(&PL_sv_undef)) {
173 /* set read-only and try to insure than we wont see REFCNT==0
176 SvREADONLY_on(&PL_sv_undef);
177 SvREFCNT(&PL_sv_undef) = (~(U32)0)/2;
179 sv_setpv(&PL_sv_no,PL_No);
181 SvREADONLY_on(&PL_sv_no);
182 SvREFCNT(&PL_sv_no) = (~(U32)0)/2;
184 sv_setpv(&PL_sv_yes,PL_Yes);
186 SvREADONLY_on(&PL_sv_yes);
187 SvREFCNT(&PL_sv_yes) = (~(U32)0)/2;
192 /* PL_sighandlerp = sighandler; */
194 PL_sighandlerp = Perl_sighandler;
196 PL_pidstatus = newHV();
200 * There is no way we can refer to them from Perl so close them to save
201 * space. The other alternative would be to provide STDAUX and STDPRN
204 (void)fclose(stdaux);
205 (void)fclose(stdprn);
209 PL_nrs = newSVpvn("\n", 1);
210 PL_rs = SvREFCNT_inc(PL_nrs);
215 PL_lex_state = LEX_NOTPARSING;
221 SET_NUMERIC_STANDARD();
225 PL_patchlevel = NEWSV(0,4);
226 SvUPGRADE(PL_patchlevel, SVt_PVNV);
227 if (PERL_REVISION > 127 || PERL_VERSION > 127 || PERL_SUBVERSION > 127)
228 SvGROW(PL_patchlevel,24);
229 s = (U8*)SvPVX(PL_patchlevel);
230 s = uv_to_utf8(s, (UV)PERL_REVISION);
231 s = uv_to_utf8(s, (UV)PERL_VERSION);
232 s = uv_to_utf8(s, (UV)PERL_SUBVERSION);
234 SvCUR_set(PL_patchlevel, s - (U8*)SvPVX(PL_patchlevel));
235 SvPOK_on(PL_patchlevel);
236 SvNVX(PL_patchlevel) = (NV)PERL_REVISION
237 + ((NV)PERL_VERSION / (NV)1000)
238 #if defined(PERL_SUBVERSION) && PERL_SUBVERSION > 0
239 + ((NV)PERL_SUBVERSION / (NV)1000000)
242 SvNOK_on(PL_patchlevel); /* dual valued */
243 SvUTF8_on(PL_patchlevel);
244 SvREADONLY_on(PL_patchlevel);
247 #if defined(LOCAL_PATCH_COUNT)
248 PL_localpatches = local_patches; /* For possible -v */
251 PerlIO_init(); /* Hook to IO system */
253 PL_fdpid = newAV(); /* for remembering popen pids by fd */
254 PL_modglobal = newHV(); /* pointers to per-interpreter module globals */
260 =for apidoc perl_destruct
262 Shuts down a Perl interpreter. See L<perlembed>.
271 int destruct_level; /* 0=none, 1=full, 2=full with checks */
277 #endif /* USE_THREADS */
279 /* wait for all pseudo-forked children to finish */
280 PERL_WAIT_FOR_CHILDREN;
284 /* Pass 1 on any remaining threads: detach joinables, join zombies */
286 MUTEX_LOCK(&PL_threads_mutex);
287 DEBUG_S(PerlIO_printf(Perl_debug_log,
288 "perl_destruct: waiting for %d threads...\n",
290 for (t = thr->next; t != thr; t = t->next) {
291 MUTEX_LOCK(&t->mutex);
292 switch (ThrSTATE(t)) {
295 DEBUG_S(PerlIO_printf(Perl_debug_log,
296 "perl_destruct: joining zombie %p\n", t));
297 ThrSETSTATE(t, THRf_DEAD);
298 MUTEX_UNLOCK(&t->mutex);
301 * The SvREFCNT_dec below may take a long time (e.g. av
302 * may contain an object scalar whose destructor gets
303 * called) so we have to unlock threads_mutex and start
306 MUTEX_UNLOCK(&PL_threads_mutex);
308 SvREFCNT_dec((SV*)av);
309 DEBUG_S(PerlIO_printf(Perl_debug_log,
310 "perl_destruct: joined zombie %p OK\n", t));
312 case THRf_R_JOINABLE:
313 DEBUG_S(PerlIO_printf(Perl_debug_log,
314 "perl_destruct: detaching thread %p\n", t));
315 ThrSETSTATE(t, THRf_R_DETACHED);
317 * We unlock threads_mutex and t->mutex in the opposite order
318 * from which we locked them just so that DETACH won't
319 * deadlock if it panics. It's only a breach of good style
320 * not a bug since they are unlocks not locks.
322 MUTEX_UNLOCK(&PL_threads_mutex);
324 MUTEX_UNLOCK(&t->mutex);
327 DEBUG_S(PerlIO_printf(Perl_debug_log,
328 "perl_destruct: ignoring %p (state %u)\n",
330 MUTEX_UNLOCK(&t->mutex);
331 /* fall through and out */
334 /* We leave the above "Pass 1" loop with threads_mutex still locked */
336 /* Pass 2 on remaining threads: wait for the thread count to drop to one */
337 while (PL_nthreads > 1)
339 DEBUG_S(PerlIO_printf(Perl_debug_log,
340 "perl_destruct: final wait for %d threads\n",
342 COND_WAIT(&PL_nthreads_cond, &PL_threads_mutex);
344 /* At this point, we're the last thread */
345 MUTEX_UNLOCK(&PL_threads_mutex);
346 DEBUG_S(PerlIO_printf(Perl_debug_log, "perl_destruct: armageddon has arrived\n"));
347 MUTEX_DESTROY(&PL_threads_mutex);
348 COND_DESTROY(&PL_nthreads_cond);
349 #endif /* !defined(FAKE_THREADS) */
350 #endif /* USE_THREADS */
352 destruct_level = PL_perl_destruct_level;
356 if (s = PerlEnv_getenv("PERL_DESTRUCT_LEVEL")) {
358 if (destruct_level < i)
367 /* We must account for everything. */
369 /* Destroy the main CV and syntax tree */
371 PL_curpad = AvARRAY(PL_comppad);
372 op_free(PL_main_root);
373 PL_main_root = Nullop;
375 PL_curcop = &PL_compiling;
376 PL_main_start = Nullop;
377 SvREFCNT_dec(PL_main_cv);
381 if (PL_sv_objcount) {
383 * Try to destruct global references. We do this first so that the
384 * destructors and destructees still exist. Some sv's might remain.
385 * Non-referenced objects are on their own.
390 /* unhook hooks which will soon be, or use, destroyed data */
391 SvREFCNT_dec(PL_warnhook);
392 PL_warnhook = Nullsv;
393 SvREFCNT_dec(PL_diehook);
396 /* call exit list functions */
397 while (PL_exitlistlen-- > 0)
398 PL_exitlist[PL_exitlistlen].fn(aTHXo_ PL_exitlist[PL_exitlistlen].ptr);
400 Safefree(PL_exitlist);
402 if (destruct_level == 0){
404 DEBUG_P(debprofdump());
406 /* The exit() function will do everything that needs doing. */
410 /* loosen bonds of global variables */
413 (void)PerlIO_close(PL_rsfp);
417 /* Filters for program text */
418 SvREFCNT_dec(PL_rsfp_filters);
419 PL_rsfp_filters = Nullav;
422 PL_preprocess = FALSE;
428 PL_doswitches = FALSE;
429 PL_dowarn = G_WARN_OFF;
430 PL_doextract = FALSE;
431 PL_sawampersand = FALSE; /* must save all match strings */
434 Safefree(PL_inplace);
436 SvREFCNT_dec(PL_patchlevel);
439 SvREFCNT_dec(PL_e_script);
440 PL_e_script = Nullsv;
443 /* magical thingies */
445 Safefree(PL_ofs); /* $, */
448 Safefree(PL_ors); /* $\ */
451 SvREFCNT_dec(PL_rs); /* $/ */
454 SvREFCNT_dec(PL_nrs); /* $/ helper */
457 PL_multiline = 0; /* $* */
459 SvREFCNT_dec(PL_statname);
460 PL_statname = Nullsv;
463 /* defgv, aka *_ should be taken care of elsewhere */
465 /* clean up after study() */
466 SvREFCNT_dec(PL_lastscream);
467 PL_lastscream = Nullsv;
468 Safefree(PL_screamfirst);
470 Safefree(PL_screamnext);
474 Safefree(PL_efloatbuf);
475 PL_efloatbuf = Nullch;
478 /* startup and shutdown function lists */
479 SvREFCNT_dec(PL_beginav);
480 SvREFCNT_dec(PL_endav);
481 SvREFCNT_dec(PL_checkav);
482 SvREFCNT_dec(PL_initav);
488 /* shortcuts just get cleared */
494 PL_argvoutgv = Nullgv;
496 PL_stderrgv = Nullgv;
497 PL_last_in_gv = Nullgv;
499 PL_debstash = Nullhv;
501 /* reset so print() ends up where we expect */
504 SvREFCNT_dec(PL_argvout_stack);
505 PL_argvout_stack = Nullav;
507 SvREFCNT_dec(PL_fdpid);
509 SvREFCNT_dec(PL_modglobal);
510 PL_modglobal = Nullhv;
511 SvREFCNT_dec(PL_preambleav);
512 PL_preambleav = Nullav;
513 SvREFCNT_dec(PL_subname);
515 SvREFCNT_dec(PL_linestr);
517 SvREFCNT_dec(PL_pidstatus);
518 PL_pidstatus = Nullhv;
519 SvREFCNT_dec(PL_toptarget);
520 PL_toptarget = Nullsv;
521 SvREFCNT_dec(PL_bodytarget);
522 PL_bodytarget = Nullsv;
523 PL_formtarget = Nullsv;
525 /* clear utf8 character classes */
526 SvREFCNT_dec(PL_utf8_alnum);
527 SvREFCNT_dec(PL_utf8_alnumc);
528 SvREFCNT_dec(PL_utf8_ascii);
529 SvREFCNT_dec(PL_utf8_alpha);
530 SvREFCNT_dec(PL_utf8_space);
531 SvREFCNT_dec(PL_utf8_cntrl);
532 SvREFCNT_dec(PL_utf8_graph);
533 SvREFCNT_dec(PL_utf8_digit);
534 SvREFCNT_dec(PL_utf8_upper);
535 SvREFCNT_dec(PL_utf8_lower);
536 SvREFCNT_dec(PL_utf8_print);
537 SvREFCNT_dec(PL_utf8_punct);
538 SvREFCNT_dec(PL_utf8_xdigit);
539 SvREFCNT_dec(PL_utf8_mark);
540 SvREFCNT_dec(PL_utf8_toupper);
541 SvREFCNT_dec(PL_utf8_tolower);
542 PL_utf8_alnum = Nullsv;
543 PL_utf8_alnumc = Nullsv;
544 PL_utf8_ascii = Nullsv;
545 PL_utf8_alpha = Nullsv;
546 PL_utf8_space = Nullsv;
547 PL_utf8_cntrl = Nullsv;
548 PL_utf8_graph = Nullsv;
549 PL_utf8_digit = Nullsv;
550 PL_utf8_upper = Nullsv;
551 PL_utf8_lower = Nullsv;
552 PL_utf8_print = Nullsv;
553 PL_utf8_punct = Nullsv;
554 PL_utf8_xdigit = Nullsv;
555 PL_utf8_mark = Nullsv;
556 PL_utf8_toupper = Nullsv;
557 PL_utf8_totitle = Nullsv;
558 PL_utf8_tolower = Nullsv;
560 if (!specialWARN(PL_compiling.cop_warnings))
561 SvREFCNT_dec(PL_compiling.cop_warnings);
562 PL_compiling.cop_warnings = Nullsv;
564 /* Prepare to destruct main symbol table. */
569 SvREFCNT_dec(PL_curstname);
570 PL_curstname = Nullsv;
572 /* clear queued errors */
573 SvREFCNT_dec(PL_errors);
577 if (destruct_level >= 2 && ckWARN_d(WARN_INTERNAL)) {
578 if (PL_scopestack_ix != 0)
579 Perl_warner(aTHX_ WARN_INTERNAL,
580 "Unbalanced scopes: %ld more ENTERs than LEAVEs\n",
581 (long)PL_scopestack_ix);
582 if (PL_savestack_ix != 0)
583 Perl_warner(aTHX_ WARN_INTERNAL,
584 "Unbalanced saves: %ld more saves than restores\n",
585 (long)PL_savestack_ix);
586 if (PL_tmps_floor != -1)
587 Perl_warner(aTHX_ WARN_INTERNAL,"Unbalanced tmps: %ld more allocs than frees\n",
588 (long)PL_tmps_floor + 1);
589 if (cxstack_ix != -1)
590 Perl_warner(aTHX_ WARN_INTERNAL,"Unbalanced context: %ld more PUSHes than POPs\n",
591 (long)cxstack_ix + 1);
594 /* Now absolutely destruct everything, somehow or other, loops or no. */
596 SvFLAGS(PL_strtab) |= SVTYPEMASK; /* don't clean out strtab now */
597 while (PL_sv_count != 0 && PL_sv_count != last_sv_count) {
598 last_sv_count = PL_sv_count;
601 SvFLAGS(PL_strtab) &= ~SVTYPEMASK;
602 SvFLAGS(PL_strtab) |= SVt_PVHV;
604 /* Destruct the global string table. */
606 /* Yell and reset the HeVAL() slots that are still holding refcounts,
607 * so that sv_free() won't fail on them.
615 max = HvMAX(PL_strtab);
616 array = HvARRAY(PL_strtab);
619 if (hent && ckWARN_d(WARN_INTERNAL)) {
620 Perl_warner(aTHX_ WARN_INTERNAL,
621 "Unbalanced string table refcount: (%d) for \"%s\"",
622 HeVAL(hent) - Nullsv, HeKEY(hent));
623 HeVAL(hent) = Nullsv;
633 SvREFCNT_dec(PL_strtab);
635 if (PL_sv_count != 0 && ckWARN_d(WARN_INTERNAL))
636 Perl_warner(aTHX_ WARN_INTERNAL,"Scalars leaked: %ld\n", (long)PL_sv_count);
640 /* No SVs have survived, need to clean out */
641 Safefree(PL_origfilename);
642 Safefree(PL_reg_start_tmp);
644 Safefree(PL_reg_curpm);
645 Safefree(PL_reg_poscache);
646 Safefree(HeKEY_hek(&PL_hv_fetch_ent_mh));
647 Safefree(PL_op_mask);
649 PL_hints = 0; /* Reset hints. Should hints be per-interpreter ? */
651 DEBUG_P(debprofdump());
653 MUTEX_DESTROY(&PL_strtab_mutex);
654 MUTEX_DESTROY(&PL_sv_mutex);
655 MUTEX_DESTROY(&PL_eval_mutex);
656 MUTEX_DESTROY(&PL_cred_mutex);
657 COND_DESTROY(&PL_eval_cond);
658 #ifdef EMULATE_ATOMIC_REFCOUNTS
659 MUTEX_DESTROY(&PL_svref_mutex);
660 #endif /* EMULATE_ATOMIC_REFCOUNTS */
662 /* As the penultimate thing, free the non-arena SV for thrsv */
663 Safefree(SvPVX(PL_thrsv));
664 Safefree(SvANY(PL_thrsv));
667 #endif /* USE_THREADS */
669 /* As the absolutely last thing, free the non-arena SV for mess() */
672 /* it could have accumulated taint magic */
673 if (SvTYPE(PL_mess_sv) >= SVt_PVMG) {
676 for (mg = SvMAGIC(PL_mess_sv); mg; mg = moremagic) {
677 moremagic = mg->mg_moremagic;
678 if (mg->mg_ptr && mg->mg_type != 'g' && mg->mg_len >= 0)
679 Safefree(mg->mg_ptr);
683 /* we know that type >= SVt_PV */
684 SvOOK_off(PL_mess_sv);
685 Safefree(SvPVX(PL_mess_sv));
686 Safefree(SvANY(PL_mess_sv));
687 Safefree(PL_mess_sv);
693 =for apidoc perl_free
695 Releases a Perl interpreter. See L<perlembed>.
703 #if defined(PERL_OBJECT)
711 Perl_call_atexit(pTHX_ ATEXIT_t fn, void *ptr)
713 Renew(PL_exitlist, PL_exitlistlen+1, PerlExitListEntry);
714 PL_exitlist[PL_exitlistlen].fn = fn;
715 PL_exitlist[PL_exitlistlen].ptr = ptr;
720 =for apidoc perl_parse
722 Tells a Perl interpreter to parse a Perl script. See L<perlembed>.
728 perl_parse(pTHXx_ XSINIT_t xsinit, int argc, char **argv, char **env)
738 #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
741 Perl_croak(aTHX_ "suidperl is no longer needed since the kernel can now execute\n\
742 setuid perl scripts securely.\n");
746 #if defined(__DYNAMIC__) && (defined(NeXT) || defined(__NeXT__))
747 _dyld_lookup_and_bind
748 ("__environ", (unsigned long *) &environ_pointer, NULL);
753 #ifndef VMS /* VMS doesn't have environ array */
754 PL_origenviron = environ;
759 /* Come here if running an undumped a.out. */
761 PL_origfilename = savepv(argv[0]);
762 PL_do_undump = FALSE;
763 cxstack_ix = -1; /* start label stack again */
765 init_postdump_symbols(argc,argv,env);
770 PL_curpad = AvARRAY(PL_comppad);
771 op_free(PL_main_root);
772 PL_main_root = Nullop;
774 PL_main_start = Nullop;
775 SvREFCNT_dec(PL_main_cv);
779 oldscope = PL_scopestack_ix;
780 PL_dowarn = G_WARN_OFF;
782 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_parse_body),
787 call_list(oldscope, PL_checkav);
793 /* my_exit() was called */
794 while (PL_scopestack_ix > oldscope)
797 PL_curstash = PL_defstash;
799 call_list(oldscope, PL_checkav);
800 return STATUS_NATIVE_EXPORT;
802 PerlIO_printf(Perl_error_log, "panic: top_env\n");
809 S_parse_body(pTHX_ va_list args)
812 int argc = PL_origargc;
813 char **argv = PL_origargv;
814 char **env = va_arg(args, char**);
815 char *scriptname = NULL;
817 VOL bool dosearch = FALSE;
822 char *cddir = Nullch;
824 XSINIT_t xsinit = va_arg(args, XSINIT_t);
826 sv_setpvn(PL_linestr,"",0);
827 sv = newSVpvn("",0); /* first used for -I flags */
831 for (argc--,argv++; argc > 0; argc--,argv++) {
832 if (argv[0][0] != '-' || !argv[0][1])
836 validarg = " PHOOEY ";
843 #ifndef PERL_STRICT_CR
867 if (s = moreswitches(s))
877 if (PL_euid != PL_uid || PL_egid != PL_gid)
878 Perl_croak(aTHX_ "No -e allowed in setuid scripts");
880 PL_e_script = newSVpvn("",0);
881 filter_add(read_e_script, NULL);
884 sv_catpv(PL_e_script, s);
886 sv_catpv(PL_e_script, argv[1]);
890 Perl_croak(aTHX_ "No code specified for -e");
891 sv_catpv(PL_e_script, "\n");
894 case 'I': /* -I handled both here and in moreswitches() */
896 if (!*++s && (s=argv[1]) != Nullch) {
901 STRLEN len = strlen(s);
904 sv_catpvn(sv, "-I", 2);
905 sv_catpvn(sv, p, len);
906 sv_catpvn(sv, " ", 1);
910 Perl_croak(aTHX_ "No directory specified for -I");
914 PL_preprocess = TRUE;
924 PL_preambleav = newAV();
925 av_push(PL_preambleav, newSVpv("use Config qw(myconfig config_vars)",0));
927 PL_Sv = newSVpv("print myconfig();",0);
929 sv_catpv(PL_Sv,"print \"\\nCharacteristics of this PERLSHR image: \\n\",");
931 sv_catpv(PL_Sv,"print \"\\nCharacteristics of this binary (from libperl): \\n\",");
933 sv_catpv(PL_Sv,"\" Compile-time options:");
935 sv_catpv(PL_Sv," DEBUGGING");
938 sv_catpv(PL_Sv," MULTIPLICITY");
941 sv_catpv(PL_Sv," USE_THREADS");
944 sv_catpv(PL_Sv," USE_ITHREADS");
947 sv_catpv(PL_Sv," USE_64_BITS");
949 # ifdef USE_LONG_DOUBLE
950 sv_catpv(PL_Sv," USE_LONG_DOUBLE");
952 # ifdef USE_LARGE_FILES
953 sv_catpv(PL_Sv," USE_LARGE_FILES");
956 sv_catpv(PL_Sv," USE_SOCKS");
959 sv_catpv(PL_Sv," PERL_OBJECT");
961 # ifdef PERL_IMPLICIT_CONTEXT
962 sv_catpv(PL_Sv," PERL_IMPLICIT_CONTEXT");
964 # ifdef PERL_IMPLICIT_SYS
965 sv_catpv(PL_Sv," PERL_IMPLICIT_SYS");
967 sv_catpv(PL_Sv,"\\n\",");
969 #if defined(LOCAL_PATCH_COUNT)
970 if (LOCAL_PATCH_COUNT > 0) {
972 sv_catpv(PL_Sv,"\" Locally applied patches:\\n\",");
973 for (i = 1; i <= LOCAL_PATCH_COUNT; i++) {
974 if (PL_localpatches[i])
975 Perl_sv_catpvf(aTHX_ PL_Sv,"q\" \t%s\n\",",PL_localpatches[i]);
979 Perl_sv_catpvf(aTHX_ PL_Sv,"\" Built under %s\\n\"",OSNAME);
982 Perl_sv_catpvf(aTHX_ PL_Sv,",\" Compiled at %s %s\\n\"",__DATE__,__TIME__);
984 Perl_sv_catpvf(aTHX_ PL_Sv,",\" Compiled on %s\\n\"",__DATE__);
989 @env = map { \"$_=\\\"$ENV{$_}\\\"\" } sort grep {/^PERL/} keys %ENV; \
990 print \" \\%ENV:\\n @env\\n\" if @env; \
991 print \" \\@INC:\\n @INC\\n\";");
994 PL_Sv = newSVpv("config_vars(qw(",0);
995 sv_catpv(PL_Sv, ++s);
996 sv_catpv(PL_Sv, "))");
999 av_push(PL_preambleav, PL_Sv);
1000 scriptname = BIT_BUCKET; /* don't look for script or read stdin */
1003 PL_doextract = TRUE;
1011 if (!*++s || isSPACE(*s)) {
1015 /* catch use of gnu style long options */
1016 if (strEQ(s, "version")) {
1020 if (strEQ(s, "help")) {
1027 Perl_croak(aTHX_ "Unrecognized switch: -%s (-h will show valid options)",s);
1033 #ifndef SECURE_INTERNAL_GETENV
1036 (s = PerlEnv_getenv("PERL5OPT")))
1040 if (*s == '-' && *(s+1) == 'T')
1053 if (!strchr("DIMUdmw", *s))
1054 Perl_croak(aTHX_ "Illegal switch in PERL5OPT: -%c", *s);
1055 s = moreswitches(s);
1061 scriptname = argv[0];
1064 scriptname = BIT_BUCKET; /* don't look for script or read stdin */
1066 else if (scriptname == Nullch) {
1068 if ( PerlLIO_isatty(PerlIO_fileno(PerlIO_stdin())) )
1076 open_script(scriptname,dosearch,sv,&fdscript);
1078 validate_suid(validarg, scriptname,fdscript);
1080 #if defined(SIGCHLD) || defined(SIGCLD)
1083 # define SIGCHLD SIGCLD
1085 Sighandler_t sigstate = rsignal_state(SIGCHLD);
1086 if (sigstate == SIG_IGN) {
1087 if (ckWARN(WARN_SIGNAL))
1088 Perl_warner(aTHX_ WARN_SIGNAL,
1089 "Can't ignore signal CHLD, forcing to default");
1090 (void)rsignal(SIGCHLD, (Sighandler_t)SIG_DFL);
1097 if (cddir && PerlDir_chdir(cddir) < 0)
1098 Perl_croak(aTHX_ "Can't chdir to %s",cddir);
1102 PL_main_cv = PL_compcv = (CV*)NEWSV(1104,0);
1103 sv_upgrade((SV *)PL_compcv, SVt_PVCV);
1104 CvUNIQUE_on(PL_compcv);
1106 PL_comppad = newAV();
1107 av_push(PL_comppad, Nullsv);
1108 PL_curpad = AvARRAY(PL_comppad);
1109 PL_comppad_name = newAV();
1110 PL_comppad_name_fill = 0;
1111 PL_min_intro_pending = 0;
1114 av_store(PL_comppad_name, 0, newSVpvn("@_", 2));
1115 PL_curpad[0] = (SV*)newAV();
1116 SvPADMY_on(PL_curpad[0]); /* XXX Needed? */
1117 CvOWNER(PL_compcv) = 0;
1118 New(666, CvMUTEXP(PL_compcv), 1, perl_mutex);
1119 MUTEX_INIT(CvMUTEXP(PL_compcv));
1120 #endif /* USE_THREADS */
1122 comppadlist = newAV();
1123 AvREAL_off(comppadlist);
1124 av_store(comppadlist, 0, (SV*)PL_comppad_name);
1125 av_store(comppadlist, 1, (SV*)PL_comppad);
1126 CvPADLIST(PL_compcv) = comppadlist;
1128 boot_core_UNIVERSAL();
1129 boot_core_xsutils();
1132 (*xsinit)(aTHXo); /* in case linked C routines want magical variables */
1133 #if defined(VMS) || defined(WIN32) || defined(DJGPP)
1141 init_predump_symbols();
1142 /* init_postdump_symbols not currently designed to be called */
1143 /* more than once (ENV isn't cleared first, for example) */
1144 /* But running with -u leaves %ENV & @ARGV undefined! XXX */
1146 init_postdump_symbols(argc,argv,env);
1150 /* now parse the script */
1152 SETERRNO(0,SS$_NORMAL);
1154 if (yyparse() || PL_error_count) {
1156 Perl_croak(aTHX_ "%s had compilation errors.\n", PL_origfilename);
1158 Perl_croak(aTHX_ "Execution of %s aborted due to compilation errors.\n",
1162 CopLINE_set(PL_curcop, 0);
1163 PL_curstash = PL_defstash;
1164 PL_preprocess = FALSE;
1166 SvREFCNT_dec(PL_e_script);
1167 PL_e_script = Nullsv;
1170 /* now that script is parsed, we can modify record separator */
1171 SvREFCNT_dec(PL_rs);
1172 PL_rs = SvREFCNT_inc(PL_nrs);
1173 sv_setsv(get_sv("/", TRUE), PL_rs);
1178 SAVECOPFILE(PL_curcop);
1179 SAVECOPLINE(PL_curcop);
1180 gv_check(PL_defstash);
1187 if ((s=PerlEnv_getenv("PERL_DEBUG_MSTATS")) && atoi(s) >= 2)
1188 dump_mstats("after compilation:");
1197 =for apidoc perl_run
1199 Tells a Perl interpreter to run. See L<perlembed>.
1215 oldscope = PL_scopestack_ix;
1218 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_run_body), oldscope);
1221 cxstack_ix = -1; /* start context stack again */
1223 case 0: /* normal completion */
1224 case 2: /* my_exit() */
1225 while (PL_scopestack_ix > oldscope)
1228 PL_curstash = PL_defstash;
1229 if (PL_endav && !PL_minus_c)
1230 call_list(oldscope, PL_endav);
1232 if (PerlEnv_getenv("PERL_DEBUG_MSTATS"))
1233 dump_mstats("after execution: ");
1235 return STATUS_NATIVE_EXPORT;
1238 POPSTACK_TO(PL_mainstack);
1241 PerlIO_printf(Perl_error_log, "panic: restartop\n");
1251 S_run_body(pTHX_ va_list args)
1254 I32 oldscope = va_arg(args, I32);
1256 DEBUG_r(PerlIO_printf(Perl_debug_log, "%s $` $& $' support.\n",
1257 PL_sawampersand ? "Enabling" : "Omitting"));
1259 if (!PL_restartop) {
1260 DEBUG_x(dump_all());
1261 DEBUG(PerlIO_printf(Perl_debug_log, "\nEXECUTING...\n\n"));
1262 DEBUG_S(PerlIO_printf(Perl_debug_log, "main thread is 0x%"UVxf"\n",
1266 PerlIO_printf(Perl_error_log, "%s syntax OK\n", PL_origfilename);
1269 if (PERLDB_SINGLE && PL_DBsingle)
1270 sv_setiv(PL_DBsingle, 1);
1272 call_list(oldscope, PL_initav);
1278 PL_op = PL_restartop;
1282 else if (PL_main_start) {
1283 CvDEPTH(PL_main_cv) = 1;
1284 PL_op = PL_main_start;
1294 =for apidoc p||get_sv
1296 Returns the SV of the specified Perl scalar. If C<create> is set and the
1297 Perl variable does not exist then it will be created. If C<create> is not
1298 set and the variable does not exist then NULL is returned.
1304 Perl_get_sv(pTHX_ const char *name, I32 create)
1308 if (name[1] == '\0' && !isALPHA(name[0])) {
1309 PADOFFSET tmp = find_threadsv(name);
1310 if (tmp != NOT_IN_PAD) {
1312 return THREADSV(tmp);
1315 #endif /* USE_THREADS */
1316 gv = gv_fetchpv(name, create, SVt_PV);
1323 =for apidoc p||get_av
1325 Returns the AV of the specified Perl array. If C<create> is set and the
1326 Perl variable does not exist then it will be created. If C<create> is not
1327 set and the variable does not exist then NULL is returned.
1333 Perl_get_av(pTHX_ const char *name, I32 create)
1335 GV* gv = gv_fetchpv(name, create, SVt_PVAV);
1344 =for apidoc p||get_hv
1346 Returns the HV of the specified Perl hash. If C<create> is set and the
1347 Perl variable does not exist then it will be created. If C<create> is not
1348 set and the variable does not exist then NULL is returned.
1354 Perl_get_hv(pTHX_ const char *name, I32 create)
1356 GV* gv = gv_fetchpv(name, create, SVt_PVHV);
1365 =for apidoc p||get_cv
1367 Returns the CV of the specified Perl subroutine. If C<create> is set and
1368 the Perl subroutine does not exist then it will be declared (which has the
1369 same effect as saying C<sub name;>). If C<create> is not set and the
1370 subroutine does not exist then NULL is returned.
1376 Perl_get_cv(pTHX_ const char *name, I32 create)
1378 GV* gv = gv_fetchpv(name, create, SVt_PVCV);
1379 /* XXX unsafe for threads if eval_owner isn't held */
1380 /* XXX this is probably not what they think they're getting.
1381 * It has the same effect as "sub name;", i.e. just a forward
1383 if (create && !GvCVu(gv))
1384 return newSUB(start_subparse(FALSE, 0),
1385 newSVOP(OP_CONST, 0, newSVpv(name,0)),
1393 /* Be sure to refetch the stack pointer after calling these routines. */
1396 =for apidoc p||call_argv
1398 Performs a callback to the specified Perl sub. See L<perlcall>.
1404 Perl_call_argv(pTHX_ const char *sub_name, I32 flags, register char **argv)
1406 /* See G_* flags in cop.h */
1407 /* null terminated arg list */
1414 XPUSHs(sv_2mortal(newSVpv(*argv,0)));
1419 return call_pv(sub_name, flags);
1423 =for apidoc p||call_pv
1425 Performs a callback to the specified Perl sub. See L<perlcall>.
1431 Perl_call_pv(pTHX_ const char *sub_name, I32 flags)
1432 /* name of the subroutine */
1433 /* See G_* flags in cop.h */
1435 return call_sv((SV*)get_cv(sub_name, TRUE), flags);
1439 =for apidoc p||call_method
1441 Performs a callback to the specified Perl method. The blessed object must
1442 be on the stack. See L<perlcall>.
1448 Perl_call_method(pTHX_ const char *methname, I32 flags)
1449 /* name of the subroutine */
1450 /* See G_* flags in cop.h */
1456 XPUSHs(sv_2mortal(newSVpv(methname,0)));
1461 return call_sv(*PL_stack_sp--, flags);
1464 /* May be called with any of a CV, a GV, or an SV containing the name. */
1466 =for apidoc p||call_sv
1468 Performs a callback to the Perl sub whose name is in the SV. See
1475 Perl_call_sv(pTHX_ SV *sv, I32 flags)
1477 /* See G_* flags in cop.h */
1480 LOGOP myop; /* fake syntax tree node */
1484 bool oldcatch = CATCH_GET;
1489 if (flags & G_DISCARD) {
1494 Zero(&myop, 1, LOGOP);
1495 myop.op_next = Nullop;
1496 if (!(flags & G_NOARGS))
1497 myop.op_flags |= OPf_STACKED;
1498 myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
1499 (flags & G_ARRAY) ? OPf_WANT_LIST :
1504 EXTEND(PL_stack_sp, 1);
1505 *++PL_stack_sp = sv;
1507 oldscope = PL_scopestack_ix;
1509 if (PERLDB_SUB && PL_curstash != PL_debstash
1510 /* Handle first BEGIN of -d. */
1511 && (PL_DBcv || (PL_DBcv = GvCV(PL_DBsub)))
1512 /* Try harder, since this may have been a sighandler, thus
1513 * curstash may be meaningless. */
1514 && (SvTYPE(sv) != SVt_PVCV || CvSTASH((CV*)sv) != PL_debstash)
1515 && !(flags & G_NODEBUG))
1516 PL_op->op_private |= OPpENTERSUB_DB;
1518 if (!(flags & G_EVAL)) {
1520 call_xbody((OP*)&myop, FALSE);
1521 retval = PL_stack_sp - (PL_stack_base + oldmark);
1522 CATCH_SET(oldcatch);
1525 cLOGOP->op_other = PL_op;
1527 /* we're trying to emulate pp_entertry() here */
1529 register PERL_CONTEXT *cx;
1530 I32 gimme = GIMME_V;
1535 push_return(PL_op->op_next);
1536 PUSHBLOCK(cx, CXt_EVAL, PL_stack_sp);
1538 PL_eval_root = PL_op; /* Only needed so that goto works right. */
1540 PL_in_eval = EVAL_INEVAL;
1541 if (flags & G_KEEPERR)
1542 PL_in_eval |= EVAL_KEEPERR;
1549 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_call_body),
1553 retval = PL_stack_sp - (PL_stack_base + oldmark);
1554 if (!(flags & G_KEEPERR))
1561 /* my_exit() was called */
1562 PL_curstash = PL_defstash;
1564 if (PL_statusvalue && !(PL_exit_flags & PERL_EXIT_EXPECTED))
1565 Perl_croak(aTHX_ "Callback called exit");
1570 PL_op = PL_restartop;
1574 PL_stack_sp = PL_stack_base + oldmark;
1575 if (flags & G_ARRAY)
1579 *++PL_stack_sp = &PL_sv_undef;
1584 if (PL_scopestack_ix > oldscope) {
1588 register PERL_CONTEXT *cx;
1599 if (flags & G_DISCARD) {
1600 PL_stack_sp = PL_stack_base + oldmark;
1610 S_call_body(pTHX_ va_list args)
1612 OP *myop = va_arg(args, OP*);
1613 int is_eval = va_arg(args, int);
1615 call_xbody(myop, is_eval);
1620 S_call_xbody(pTHX_ OP *myop, int is_eval)
1624 if (PL_op == myop) {
1626 PL_op = Perl_pp_entereval(aTHX);
1628 PL_op = Perl_pp_entersub(aTHX);
1634 /* Eval a string. The G_EVAL flag is always assumed. */
1637 =for apidoc p||eval_sv
1639 Tells Perl to C<eval> the string in the SV.
1645 Perl_eval_sv(pTHX_ SV *sv, I32 flags)
1647 /* See G_* flags in cop.h */
1650 UNOP myop; /* fake syntax tree node */
1651 I32 oldmark = SP - PL_stack_base;
1658 if (flags & G_DISCARD) {
1665 Zero(PL_op, 1, UNOP);
1666 EXTEND(PL_stack_sp, 1);
1667 *++PL_stack_sp = sv;
1668 oldscope = PL_scopestack_ix;
1670 if (!(flags & G_NOARGS))
1671 myop.op_flags = OPf_STACKED;
1672 myop.op_next = Nullop;
1673 myop.op_type = OP_ENTEREVAL;
1674 myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
1675 (flags & G_ARRAY) ? OPf_WANT_LIST :
1677 if (flags & G_KEEPERR)
1678 myop.op_flags |= OPf_SPECIAL;
1681 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_call_body),
1685 retval = PL_stack_sp - (PL_stack_base + oldmark);
1686 if (!(flags & G_KEEPERR))
1693 /* my_exit() was called */
1694 PL_curstash = PL_defstash;
1696 if (PL_statusvalue && !(PL_exit_flags & PERL_EXIT_EXPECTED))
1697 Perl_croak(aTHX_ "Callback called exit");
1702 PL_op = PL_restartop;
1706 PL_stack_sp = PL_stack_base + oldmark;
1707 if (flags & G_ARRAY)
1711 *++PL_stack_sp = &PL_sv_undef;
1716 if (flags & G_DISCARD) {
1717 PL_stack_sp = PL_stack_base + oldmark;
1727 =for apidoc p||eval_pv
1729 Tells Perl to C<eval> the given string and return an SV* result.
1735 Perl_eval_pv(pTHX_ const char *p, I32 croak_on_error)
1738 SV* sv = newSVpv(p, 0);
1741 eval_sv(sv, G_SCALAR);
1748 if (croak_on_error && SvTRUE(ERRSV)) {
1750 Perl_croak(aTHX_ SvPVx(ERRSV, n_a));
1756 /* Require a module. */
1759 =for apidoc p||require_pv
1761 Tells Perl to C<require> a module.
1767 Perl_require_pv(pTHX_ const char *pv)
1771 PUSHSTACKi(PERLSI_REQUIRE);
1773 sv = sv_newmortal();
1774 sv_setpv(sv, "require '");
1777 eval_sv(sv, G_DISCARD);
1783 Perl_magicname(pTHX_ char *sym, char *name, I32 namlen)
1787 if (gv = gv_fetchpv(sym,TRUE, SVt_PV))
1788 sv_magic(GvSV(gv), (SV*)gv, 0, name, namlen);
1792 S_usage(pTHX_ char *name) /* XXX move this out into a module ? */
1794 /* This message really ought to be max 23 lines.
1795 * Removed -h because the user already knows that opton. Others? */
1797 static char *usage_msg[] = {
1798 "-0[octal] specify record separator (\\0, if no argument)",
1799 "-a autosplit mode with -n or -p (splits $_ into @F)",
1800 "-c check syntax only (runs BEGIN and END blocks)",
1801 "-d[:debugger] run program under debugger",
1802 "-D[number/list] set debugging flags (argument is a bit mask or alphabets)",
1803 "-e 'command' one line of program (several -e's allowed, omit programfile)",
1804 "-F/pattern/ split() pattern for -a switch (//'s are optional)",
1805 "-i[extension] edit <> files in place (makes backup if extension supplied)",
1806 "-Idirectory specify @INC/#include directory (several -I's allowed)",
1807 "-l[octal] enable line ending processing, specifies line terminator",
1808 "-[mM][-]module execute `use/no module...' before executing program",
1809 "-n assume 'while (<>) { ... }' loop around program",
1810 "-p assume loop like -n but print line also, like sed",
1811 "-P run program through C preprocessor before compilation",
1812 "-s enable rudimentary parsing for switches after programfile",
1813 "-S look for programfile using PATH environment variable",
1814 "-T enable tainting checks",
1815 "-u dump core after parsing program",
1816 "-U allow unsafe operations",
1817 "-v print version, subversion (includes VERY IMPORTANT perl info)",
1818 "-V[:variable] print configuration summary (or a single Config.pm variable)",
1819 "-w enable many useful warnings (RECOMMENDED)",
1820 "-x[directory] strip off text before #!perl line and perhaps cd to directory",
1824 char **p = usage_msg;
1826 printf("\nUsage: %s [switches] [--] [programfile] [arguments]", name);
1828 printf("\n %s", *p++);
1831 /* This routine handles any switches that can be given during run */
1834 Perl_moreswitches(pTHX_ char *s)
1843 rschar = (U32)scan_oct(s, 4, &numlen);
1844 SvREFCNT_dec(PL_nrs);
1845 if (rschar & ~((U8)~0))
1846 PL_nrs = &PL_sv_undef;
1847 else if (!rschar && numlen >= 2)
1848 PL_nrs = newSVpvn("", 0);
1851 PL_nrs = newSVpvn(&ch, 1);
1857 PL_splitstr = savepv(s + 1);
1871 if (*s == ':' || *s == '=') {
1872 my_setenv("PERL5DB", Perl_form(aTHX_ "use Devel::%s;", ++s));
1876 PL_perldb = PERLDB_ALL;
1884 if (isALPHA(s[1])) {
1885 static char debopts[] = "psltocPmfrxuLHXDS";
1888 for (s++; *s && (d = strchr(debopts,*s)); s++)
1889 PL_debug |= 1 << (d - debopts);
1892 PL_debug = atoi(s+1);
1893 for (s++; isDIGIT(*s); s++) ;
1895 PL_debug |= 0x80000000;
1898 if (ckWARN_d(WARN_DEBUGGING))
1899 Perl_warner(aTHX_ WARN_DEBUGGING,
1900 "Recompile perl with -DDEBUGGING to use -D switch\n");
1901 for (s++; isALNUM(*s); s++) ;
1907 usage(PL_origargv[0]);
1911 Safefree(PL_inplace);
1912 PL_inplace = savepv(s+1);
1914 for (s = PL_inplace; *s && !isSPACE(*s); s++) ;
1917 if (*s == '-') /* Additional switches on #! line. */
1921 case 'I': /* -I handled both here and in parse_perl() */
1924 while (*s && isSPACE(*s))
1929 /* ignore trailing spaces (possibly followed by other switches) */
1931 for (e = p; *e && !isSPACE(*e); e++) ;
1935 } while (*p && *p != '-');
1936 e = savepvn(s, e-s);
1944 Perl_croak(aTHX_ "No directory specified for -I");
1952 PL_ors = savepv("\n");
1954 *PL_ors = (char)scan_oct(s, 3 + (*s == '0'), &numlen);
1959 if (RsPARA(PL_nrs)) {
1964 PL_ors = SvPV(PL_nrs, PL_orslen);
1965 PL_ors = savepvn(PL_ors, PL_orslen);
1969 forbid_setid("-M"); /* XXX ? */
1972 forbid_setid("-m"); /* XXX ? */
1977 /* -M-foo == 'no foo' */
1978 if (*s == '-') { use = "no "; ++s; }
1979 sv = newSVpv(use,0);
1981 /* We allow -M'Module qw(Foo Bar)' */
1982 while(isALNUM(*s) || *s==':') ++s;
1984 sv_catpv(sv, start);
1985 if (*(start-1) == 'm') {
1987 Perl_croak(aTHX_ "Can't use '%c' after -mname", *s);
1988 sv_catpv( sv, " ()");
1991 sv_catpvn(sv, start, s-start);
1992 sv_catpv(sv, " split(/,/,q{");
1998 PL_preambleav = newAV();
1999 av_push(PL_preambleav, sv);
2002 Perl_croak(aTHX_ "No space allowed after -%c", *(s-1));
2014 PL_doswitches = TRUE;
2019 Perl_croak(aTHX_ "Too late for \"-T\" option");
2023 PL_do_undump = TRUE;
2031 printf(Perl_form(aTHX_ "\nThis is perl, v%v built for %s",
2032 PL_patchlevel, ARCHNAME));
2033 #if defined(LOCAL_PATCH_COUNT)
2034 if (LOCAL_PATCH_COUNT > 0)
2035 printf("\n(with %d registered patch%s, see perl -V for more detail)",
2036 (int)LOCAL_PATCH_COUNT, (LOCAL_PATCH_COUNT!=1) ? "es" : "");
2039 printf("\n\nCopyright 1987-2000, Larry Wall\n");
2041 printf("\nMS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n");
2044 printf("djgpp v2 port (jpl5003c) by Hirofumi Watanabe, 1996\n");
2045 printf("djgpp v2 port (perl5004+) by Laszlo Molnar, 1997-1999\n");
2048 printf("\n\nOS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n"
2049 "Version 5 port Copyright (c) 1994-1999, Andreas Kaiser, Ilya Zakharevich\n");
2052 printf("atariST series port, ++jrb bammi@cadence.com\n");
2055 printf("BeOS port Copyright Tom Spindler, 1997-1999\n");
2058 printf("MPE/iX port Copyright by Mark Klein and Mark Bixby, 1996-1999\n");
2061 printf("MVS (OS390) port by Mortice Kern Systems, 1997-1999\n");
2064 printf("Stratus VOS port by Paul_Green@stratus.com, 1997-1999\n");
2067 printf("VM/ESA port by Neale Ferguson, 1998-1999\n");
2070 printf("BS2000 (POSIX) port by Start Amadeus GmbH, 1998-1999\n");
2073 printf("MiNT port by Guido Flohr, 1997-1999\n");
2075 #ifdef BINARY_BUILD_NOTICE
2076 BINARY_BUILD_NOTICE;
2079 Perl may be copied only under the terms of either the Artistic License or the\n\
2080 GNU General Public License, which may be found in the Perl 5.0 source kit.\n\n\
2081 Complete documentation for Perl, including FAQ lists, should be found on\n\
2082 this system using `man perl' or `perldoc perl'. If you have access to the\n\
2083 Internet, point your browser at http://www.perl.com/, the Perl Home Page.\n\n");
2086 if (! (PL_dowarn & G_WARN_ALL_MASK))
2087 PL_dowarn |= G_WARN_ON;
2091 PL_dowarn = G_WARN_ALL_ON|G_WARN_ON;
2092 PL_compiling.cop_warnings = WARN_ALL ;
2096 PL_dowarn = G_WARN_ALL_OFF;
2097 PL_compiling.cop_warnings = WARN_NONE ;
2102 if (s[1] == '-') /* Additional switches on #! line. */
2107 #if defined(WIN32) || !defined(PERL_STRICT_CR)
2113 #ifdef ALTERNATE_SHEBANG
2114 case 'S': /* OS/2 needs -S on "extproc" line. */
2122 Perl_croak(aTHX_ "Can't emulate -%.1s on #! line",s);
2127 /* compliments of Tom Christiansen */
2129 /* unexec() can be found in the Gnu emacs distribution */
2130 /* Known to work with -DUNEXEC and using unexelf.c from GNU emacs-20.2 */
2133 Perl_my_unexec(pTHX)
2141 prog = newSVpv(BIN_EXP, 0);
2142 sv_catpv(prog, "/perl");
2143 file = newSVpv(PL_origfilename, 0);
2144 sv_catpv(file, ".perldump");
2146 unexec(SvPVX(file), SvPVX(prog), &etext, sbrk(0), 0);
2147 /* unexec prints msg to stderr in case of failure */
2148 PerlProc_exit(status);
2151 # include <lib$routines.h>
2152 lib$signal(SS$_DEBUG); /* ssdef.h #included from vmsish.h */
2154 ABORT(); /* for use with undump */
2159 /* initialize curinterp */
2164 #ifdef PERL_OBJECT /* XXX kludge */
2167 PL_chopset = " \n-"; \
2168 PL_copline = NOLINE; \
2169 PL_curcop = &PL_compiling;\
2170 PL_curcopdb = NULL; \
2172 PL_dumpindent = 4; \
2173 PL_laststatval = -1; \
2174 PL_laststype = OP_STAT; \
2175 PL_maxscream = -1; \
2176 PL_maxsysfd = MAXSYSFD; \
2177 PL_statname = Nullsv; \
2178 PL_tmps_floor = -1; \
2180 PL_op_mask = NULL; \
2181 PL_laststatval = -1; \
2182 PL_laststype = OP_STAT; \
2183 PL_mess_sv = Nullsv; \
2184 PL_splitstr = " "; \
2185 PL_generation = 100; \
2186 PL_exitlist = NULL; \
2187 PL_exitlistlen = 0; \
2189 PL_in_clean_objs = FALSE; \
2190 PL_in_clean_all = FALSE; \
2191 PL_profiledata = NULL; \
2193 PL_rsfp_filters = Nullav; \
2198 # ifdef MULTIPLICITY
2199 # define PERLVAR(var,type)
2200 # define PERLVARA(var,n,type)
2201 # if defined(PERL_IMPLICIT_CONTEXT)
2202 # if defined(USE_THREADS)
2203 # define PERLVARI(var,type,init) PERL_GET_INTERP->var = init;
2204 # define PERLVARIC(var,type,init) PERL_GET_INTERP->var = init;
2205 # else /* !USE_THREADS */
2206 # define PERLVARI(var,type,init) aTHX->var = init;
2207 # define PERLVARIC(var,type,init) aTHX->var = init;
2208 # endif /* USE_THREADS */
2210 # define PERLVARI(var,type,init) PERL_GET_INTERP->var = init;
2211 # define PERLVARIC(var,type,init) PERL_GET_INTERP->var = init;
2213 # include "intrpvar.h"
2214 # ifndef USE_THREADS
2215 # include "thrdvar.h"
2222 # define PERLVAR(var,type)
2223 # define PERLVARA(var,n,type)
2224 # define PERLVARI(var,type,init) PL_##var = init;
2225 # define PERLVARIC(var,type,init) PL_##var = init;
2226 # include "intrpvar.h"
2227 # ifndef USE_THREADS
2228 # include "thrdvar.h"
2240 S_init_main_stash(pTHX)
2245 /* Note that strtab is a rather special HV. Assumptions are made
2246 about not iterating on it, and not adding tie magic to it.
2247 It is properly deallocated in perl_destruct() */
2248 PL_strtab = newHV();
2250 MUTEX_INIT(&PL_strtab_mutex);
2252 HvSHAREKEYS_off(PL_strtab); /* mandatory */
2253 hv_ksplit(PL_strtab, 512);
2255 PL_curstash = PL_defstash = newHV();
2256 PL_curstname = newSVpvn("main",4);
2257 gv = gv_fetchpv("main::",TRUE, SVt_PVHV);
2258 SvREFCNT_dec(GvHV(gv));
2259 GvHV(gv) = (HV*)SvREFCNT_inc(PL_defstash);
2261 HvNAME(PL_defstash) = savepv("main");
2262 PL_incgv = gv_HVadd(gv_AVadd(gv_fetchpv("INC",TRUE, SVt_PVAV)));
2263 GvMULTI_on(PL_incgv);
2264 PL_hintgv = gv_fetchpv("\010",TRUE, SVt_PV); /* ^H */
2265 GvMULTI_on(PL_hintgv);
2266 PL_defgv = gv_fetchpv("_",TRUE, SVt_PVAV);
2267 PL_errgv = gv_HVadd(gv_fetchpv("@", TRUE, SVt_PV));
2268 GvMULTI_on(PL_errgv);
2269 PL_replgv = gv_fetchpv("\022", TRUE, SVt_PV); /* ^R */
2270 GvMULTI_on(PL_replgv);
2271 (void)Perl_form(aTHX_ "%240s",""); /* Preallocate temp - for immediate signals. */
2272 sv_grow(ERRSV, 240); /* Preallocate - for immediate signals. */
2273 sv_setpvn(ERRSV, "", 0);
2274 PL_curstash = PL_defstash;
2275 CopSTASH_set(&PL_compiling, PL_defstash);
2276 PL_debstash = GvHV(gv_fetchpv("DB::", GV_ADDMULTI, SVt_PVHV));
2277 PL_globalstash = GvHV(gv_fetchpv("CORE::GLOBAL::", GV_ADDMULTI, SVt_PVHV));
2278 /* We must init $/ before switches are processed. */
2279 sv_setpvn(get_sv("/", TRUE), "\n", 1);
2283 S_open_script(pTHX_ char *scriptname, bool dosearch, SV *sv, int *fdscript)
2291 PL_origfilename = savepv("-e");
2294 /* if find_script() returns, it returns a malloc()-ed value */
2295 PL_origfilename = scriptname = find_script(scriptname, dosearch, NULL, 1);
2297 if (strnEQ(scriptname, "/dev/fd/", 8) && isDIGIT(scriptname[8]) ) {
2298 char *s = scriptname + 8;
2299 *fdscript = atoi(s);
2303 scriptname = savepv(s + 1);
2304 Safefree(PL_origfilename);
2305 PL_origfilename = scriptname;
2310 CopFILE_set(PL_curcop, PL_origfilename);
2311 if (strEQ(PL_origfilename,"-"))
2313 if (*fdscript >= 0) {
2314 PL_rsfp = PerlIO_fdopen(*fdscript,PERL_SCRIPT_MODE);
2315 #if defined(HAS_FCNTL) && defined(F_SETFD)
2317 fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,1); /* ensure close-on-exec */
2320 else if (PL_preprocess) {
2321 char *cpp_cfg = CPPSTDIN;
2322 SV *cpp = newSVpvn("",0);
2323 SV *cmd = NEWSV(0,0);
2325 if (strEQ(cpp_cfg, "cppstdin"))
2326 Perl_sv_catpvf(aTHX_ cpp, "%s/", BIN_EXP);
2327 sv_catpv(cpp, cpp_cfg);
2329 sv_catpvn(sv, "-I", 2);
2330 sv_catpv(sv,PRIVLIB_EXP);
2333 Perl_sv_setpvf(aTHX_ cmd, "\
2334 sed %s -e \"/^[^#]/b\" \
2335 -e \"/^#[ ]*include[ ]/b\" \
2336 -e \"/^#[ ]*define[ ]/b\" \
2337 -e \"/^#[ ]*if[ ]/b\" \
2338 -e \"/^#[ ]*ifdef[ ]/b\" \
2339 -e \"/^#[ ]*ifndef[ ]/b\" \
2340 -e \"/^#[ ]*else/b\" \
2341 -e \"/^#[ ]*elif[ ]/b\" \
2342 -e \"/^#[ ]*undef[ ]/b\" \
2343 -e \"/^#[ ]*endif/b\" \
2345 %s | %"SVf" -C %"SVf" %s",
2346 (PL_doextract ? "-e \"1,/^#/d\n\"" : ""),
2349 Perl_sv_setpvf(aTHX_ cmd, "\
2350 %s %s -e '/^[^#]/b' \
2351 -e '/^#[ ]*include[ ]/b' \
2352 -e '/^#[ ]*define[ ]/b' \
2353 -e '/^#[ ]*if[ ]/b' \
2354 -e '/^#[ ]*ifdef[ ]/b' \
2355 -e '/^#[ ]*ifndef[ ]/b' \
2356 -e '/^#[ ]*else/b' \
2357 -e '/^#[ ]*elif[ ]/b' \
2358 -e '/^#[ ]*undef[ ]/b' \
2359 -e '/^#[ ]*endif/b' \
2361 %s | %"SVf" %"SVf" %s",
2363 Perl_sv_setpvf(aTHX_ cmd, "\
2364 %s %s -e '/^[^#]/b' \
2365 -e '/^#[ ]*include[ ]/b' \
2366 -e '/^#[ ]*define[ ]/b' \
2367 -e '/^#[ ]*if[ ]/b' \
2368 -e '/^#[ ]*ifdef[ ]/b' \
2369 -e '/^#[ ]*ifndef[ ]/b' \
2370 -e '/^#[ ]*else/b' \
2371 -e '/^#[ ]*elif[ ]/b' \
2372 -e '/^#[ ]*undef[ ]/b' \
2373 -e '/^#[ ]*endif/b' \
2375 %s | %"SVf" -C %"SVf" %s",
2382 (PL_doextract ? "-e '1,/^#/d\n'" : ""),
2384 scriptname, cpp, sv, CPPMINUS);
2385 PL_doextract = FALSE;
2386 #ifdef IAMSUID /* actually, this is caught earlier */
2387 if (PL_euid != PL_uid && !PL_euid) { /* if running suidperl */
2389 (void)seteuid(PL_uid); /* musn't stay setuid root */
2392 (void)setreuid((Uid_t)-1, PL_uid);
2394 #ifdef HAS_SETRESUID
2395 (void)setresuid((Uid_t)-1, PL_uid, (Uid_t)-1);
2397 PerlProc_setuid(PL_uid);
2401 if (PerlProc_geteuid() != PL_uid)
2402 Perl_croak(aTHX_ "Can't do seteuid!\n");
2404 #endif /* IAMSUID */
2405 PL_rsfp = PerlProc_popen(SvPVX(cmd), "r");
2409 else if (!*scriptname) {
2410 forbid_setid("program input from stdin");
2411 PL_rsfp = PerlIO_stdin();
2414 PL_rsfp = PerlIO_open(scriptname,PERL_SCRIPT_MODE);
2415 #if defined(HAS_FCNTL) && defined(F_SETFD)
2417 fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,1); /* ensure close-on-exec */
2422 #ifndef IAMSUID /* in case script is not readable before setuid */
2424 PerlLIO_stat(CopFILE(PL_curcop),&PL_statbuf) >= 0 &&
2425 PL_statbuf.st_mode & (S_ISUID|S_ISGID))
2428 PerlProc_execv(Perl_form(aTHX_ "%s/sperl"PERL_FS_VER_FMT, BIN_EXP,
2429 (int)PERL_REVISION, (int)PERL_VERSION,
2430 (int)PERL_SUBVERSION), PL_origargv);
2431 Perl_croak(aTHX_ "Can't do setuid\n");
2435 Perl_croak(aTHX_ "Can't open perl script \"%s\": %s\n",
2436 CopFILE(PL_curcop), Strerror(errno));
2441 * I_SYSSTATVFS HAS_FSTATVFS
2443 * I_STATFS HAS_FSTATFS
2444 * I_MNTENT HAS_GETMNTENT HAS_HASMNTOPT
2445 * here so that metaconfig picks them up. */
2449 S_fd_on_nosuid_fs(pTHX_ int fd)
2451 int check_okay = 0; /* able to do all the required sys/libcalls */
2452 int on_nosuid = 0; /* the fd is on a nosuid fs */
2454 * Preferred order: fstatvfs(), fstatfs(), ustat()+getmnt(), getmntent().
2455 * fstatvfs() is UNIX98.
2456 * fstatfs() is 4.3 BSD.
2457 * ustat()+getmnt() is pre-4.3 BSD.
2458 * getmntent() is O(number-of-mounted-filesystems) and can hang on
2459 * an irrelevant filesystem while trying to reach the right one.
2462 # ifdef HAS_FSTATVFS
2463 struct statvfs stfs;
2464 check_okay = fstatvfs(fd, &stfs) == 0;
2465 on_nosuid = check_okay && (stfs.f_flag & ST_NOSUID);
2467 # ifdef PERL_MOUNT_NOSUID
2468 # if defined(HAS_FSTATFS) && \
2469 defined(HAS_STRUCT_STATFS) && \
2470 defined(HAS_STRUCT_STATFS_F_FLAGS)
2472 check_okay = fstatfs(fd, &stfs) == 0;
2473 on_nosuid = check_okay && (stfs.f_flags & PERL_MOUNT_NOSUID);
2475 # if defined(HAS_FSTAT) && \
2476 defined(HAS_USTAT) && \
2477 defined(HAS_GETMNT) && \
2478 defined(HAS_STRUCT_FS_DATA) && \
2481 if (fstat(fd, &fdst) == 0) {
2483 if (ustat(fdst.st_dev, &us) == 0) {
2485 /* NOSTAT_ONE here because we're not examining fields which
2486 * vary between that case and STAT_ONE. */
2487 if (getmnt((int*)0, &fsd, (int)0, NOSTAT_ONE, us.f_fname) == 0) {
2488 size_t cmplen = sizeof(us.f_fname);
2489 if (sizeof(fsd.fd_req.path) < cmplen)
2490 cmplen = sizeof(fsd.fd_req.path);
2491 if (strnEQ(fsd.fd_req.path, us.f_fname, cmplen) &&
2492 fdst.st_dev == fsd.fd_req.dev) {
2494 on_nosuid = fsd.fd_req.flags & PERL_MOUNT_NOSUID;
2500 # endif /* fstat+ustat+getmnt */
2501 # endif /* fstatfs */
2503 # if defined(HAS_GETMNTENT) && \
2504 defined(HAS_HASMNTOPT) && \
2505 defined(MNTOPT_NOSUID)
2506 FILE *mtab = fopen("/etc/mtab", "r");
2507 struct mntent *entry;
2508 struct stat stb, fsb;
2510 if (mtab && (fstat(fd, &stb) == 0)) {
2511 while (entry = getmntent(mtab)) {
2512 if (stat(entry->mnt_dir, &fsb) == 0
2513 && fsb.st_dev == stb.st_dev)
2515 /* found the filesystem */
2517 if (hasmntopt(entry, MNTOPT_NOSUID))
2520 } /* A single fs may well fail its stat(). */
2525 # endif /* getmntent+hasmntopt */
2526 # endif /* PERL_MOUNT_NOSUID: fstatfs or fstat+ustat+statfs */
2527 # endif /* statvfs */
2530 Perl_croak(aTHX_ "Can't check filesystem of script \"%s\" for nosuid", PL_origfilename);
2533 #endif /* IAMSUID */
2536 S_validate_suid(pTHX_ char *validarg, char *scriptname, int fdscript)
2540 /* do we need to emulate setuid on scripts? */
2542 /* This code is for those BSD systems that have setuid #! scripts disabled
2543 * in the kernel because of a security problem. Merely defining DOSUID
2544 * in perl will not fix that problem, but if you have disabled setuid
2545 * scripts in the kernel, this will attempt to emulate setuid and setgid
2546 * on scripts that have those now-otherwise-useless bits set. The setuid
2547 * root version must be called suidperl or sperlN.NNN. If regular perl
2548 * discovers that it has opened a setuid script, it calls suidperl with
2549 * the same argv that it had. If suidperl finds that the script it has
2550 * just opened is NOT setuid root, it sets the effective uid back to the
2551 * uid. We don't just make perl setuid root because that loses the
2552 * effective uid we had before invoking perl, if it was different from the
2555 * DOSUID must be defined in both perl and suidperl, and IAMSUID must
2556 * be defined in suidperl only. suidperl must be setuid root. The
2557 * Configure script will set this up for you if you want it.
2564 if (PerlLIO_fstat(PerlIO_fileno(PL_rsfp),&PL_statbuf) < 0) /* normal stat is insecure */
2565 Perl_croak(aTHX_ "Can't stat script \"%s\"",PL_origfilename);
2566 if (fdscript < 0 && PL_statbuf.st_mode & (S_ISUID|S_ISGID)) {
2571 #ifndef HAS_SETREUID
2572 /* On this access check to make sure the directories are readable,
2573 * there is actually a small window that the user could use to make
2574 * filename point to an accessible directory. So there is a faint
2575 * chance that someone could execute a setuid script down in a
2576 * non-accessible directory. I don't know what to do about that.
2577 * But I don't think it's too important. The manual lies when
2578 * it says access() is useful in setuid programs.
2580 if (PerlLIO_access(CopFILE(PL_curcop),1)) /*double check*/
2581 Perl_croak(aTHX_ "Permission denied");
2583 /* If we can swap euid and uid, then we can determine access rights
2584 * with a simple stat of the file, and then compare device and
2585 * inode to make sure we did stat() on the same file we opened.
2586 * Then we just have to make sure he or she can execute it.
2589 struct stat tmpstatbuf;
2593 setreuid(PL_euid,PL_uid) < 0
2596 setresuid(PL_euid,PL_uid,(Uid_t)-1) < 0
2599 || PerlProc_getuid() != PL_euid || PerlProc_geteuid() != PL_uid)
2600 Perl_croak(aTHX_ "Can't swap uid and euid"); /* really paranoid */
2601 if (PerlLIO_stat(CopFILE(PL_curcop),&tmpstatbuf) < 0)
2602 Perl_croak(aTHX_ "Permission denied"); /* testing full pathname here */
2603 #if defined(IAMSUID) && !defined(NO_NOSUID_CHECK)
2604 if (fd_on_nosuid_fs(PerlIO_fileno(PL_rsfp)))
2605 Perl_croak(aTHX_ "Permission denied");
2607 if (tmpstatbuf.st_dev != PL_statbuf.st_dev ||
2608 tmpstatbuf.st_ino != PL_statbuf.st_ino) {
2609 (void)PerlIO_close(PL_rsfp);
2610 if (PL_rsfp = PerlProc_popen("/bin/mail root","w")) { /* heh, heh */
2611 PerlIO_printf(PL_rsfp,
2612 "User %"Uid_t_f" tried to run dev %ld ino %ld in place of dev %ld ino %ld!\n\
2613 (Filename of set-id script was %s, uid %"Uid_t_f" gid %"Gid_t_f".)\n\nSincerely,\nperl\n",
2614 PL_uid,(long)tmpstatbuf.st_dev, (long)tmpstatbuf.st_ino,
2615 (long)PL_statbuf.st_dev, (long)PL_statbuf.st_ino,
2617 PL_statbuf.st_uid, PL_statbuf.st_gid);
2618 (void)PerlProc_pclose(PL_rsfp);
2620 Perl_croak(aTHX_ "Permission denied\n");
2624 setreuid(PL_uid,PL_euid) < 0
2626 # if defined(HAS_SETRESUID)
2627 setresuid(PL_uid,PL_euid,(Uid_t)-1) < 0
2630 || PerlProc_getuid() != PL_uid || PerlProc_geteuid() != PL_euid)
2631 Perl_croak(aTHX_ "Can't reswap uid and euid");
2632 if (!cando(S_IXUSR,FALSE,&PL_statbuf)) /* can real uid exec? */
2633 Perl_croak(aTHX_ "Permission denied\n");
2635 #endif /* HAS_SETREUID */
2636 #endif /* IAMSUID */
2638 if (!S_ISREG(PL_statbuf.st_mode))
2639 Perl_croak(aTHX_ "Permission denied");
2640 if (PL_statbuf.st_mode & S_IWOTH)
2641 Perl_croak(aTHX_ "Setuid/gid script is writable by world");
2642 PL_doswitches = FALSE; /* -s is insecure in suid */
2643 CopLINE_inc(PL_curcop);
2644 if (sv_gets(PL_linestr, PL_rsfp, 0) == Nullch ||
2645 strnNE(SvPV(PL_linestr,n_a),"#!",2) ) /* required even on Sys V */
2646 Perl_croak(aTHX_ "No #! line");
2647 s = SvPV(PL_linestr,n_a)+2;
2649 while (!isSPACE(*s)) s++;
2650 for (s2 = s; (s2 > SvPV(PL_linestr,n_a)+2 &&
2651 (isDIGIT(s2[-1]) || strchr("._-", s2[-1]))); s2--) ;
2652 if (strnNE(s2-4,"perl",4) && strnNE(s-9,"perl",4)) /* sanity check */
2653 Perl_croak(aTHX_ "Not a perl script");
2654 while (*s == ' ' || *s == '\t') s++;
2656 * #! arg must be what we saw above. They can invoke it by
2657 * mentioning suidperl explicitly, but they may not add any strange
2658 * arguments beyond what #! says if they do invoke suidperl that way.
2660 len = strlen(validarg);
2661 if (strEQ(validarg," PHOOEY ") ||
2662 strnNE(s,validarg,len) || !isSPACE(s[len]))
2663 Perl_croak(aTHX_ "Args must match #! line");
2666 if (PL_euid != PL_uid && (PL_statbuf.st_mode & S_ISUID) &&
2667 PL_euid == PL_statbuf.st_uid)
2669 Perl_croak(aTHX_ "YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
2670 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
2671 #endif /* IAMSUID */
2673 if (PL_euid) { /* oops, we're not the setuid root perl */
2674 (void)PerlIO_close(PL_rsfp);
2677 PerlProc_execv(Perl_form(aTHX_ "%s/sperl"PERL_FS_VER_FMT, BIN_EXP,
2678 (int)PERL_REVISION, (int)PERL_VERSION,
2679 (int)PERL_SUBVERSION), PL_origargv);
2681 Perl_croak(aTHX_ "Can't do setuid\n");
2684 if (PL_statbuf.st_mode & S_ISGID && PL_statbuf.st_gid != PL_egid) {
2686 (void)setegid(PL_statbuf.st_gid);
2689 (void)setregid((Gid_t)-1,PL_statbuf.st_gid);
2691 #ifdef HAS_SETRESGID
2692 (void)setresgid((Gid_t)-1,PL_statbuf.st_gid,(Gid_t)-1);
2694 PerlProc_setgid(PL_statbuf.st_gid);
2698 if (PerlProc_getegid() != PL_statbuf.st_gid)
2699 Perl_croak(aTHX_ "Can't do setegid!\n");
2701 if (PL_statbuf.st_mode & S_ISUID) {
2702 if (PL_statbuf.st_uid != PL_euid)
2704 (void)seteuid(PL_statbuf.st_uid); /* all that for this */
2707 (void)setreuid((Uid_t)-1,PL_statbuf.st_uid);
2709 #ifdef HAS_SETRESUID
2710 (void)setresuid((Uid_t)-1,PL_statbuf.st_uid,(Uid_t)-1);
2712 PerlProc_setuid(PL_statbuf.st_uid);
2716 if (PerlProc_geteuid() != PL_statbuf.st_uid)
2717 Perl_croak(aTHX_ "Can't do seteuid!\n");
2719 else if (PL_uid) { /* oops, mustn't run as root */
2721 (void)seteuid((Uid_t)PL_uid);
2724 (void)setreuid((Uid_t)-1,(Uid_t)PL_uid);
2726 #ifdef HAS_SETRESUID
2727 (void)setresuid((Uid_t)-1,(Uid_t)PL_uid,(Uid_t)-1);
2729 PerlProc_setuid((Uid_t)PL_uid);
2733 if (PerlProc_geteuid() != PL_uid)
2734 Perl_croak(aTHX_ "Can't do seteuid!\n");
2737 if (!cando(S_IXUSR,TRUE,&PL_statbuf))
2738 Perl_croak(aTHX_ "Permission denied\n"); /* they can't do this */
2741 else if (PL_preprocess)
2742 Perl_croak(aTHX_ "-P not allowed for setuid/setgid script\n");
2743 else if (fdscript >= 0)
2744 Perl_croak(aTHX_ "fd script not allowed in suidperl\n");
2746 Perl_croak(aTHX_ "Script is not setuid/setgid in suidperl\n");
2748 /* We absolutely must clear out any saved ids here, so we */
2749 /* exec the real perl, substituting fd script for scriptname. */
2750 /* (We pass script name as "subdir" of fd, which perl will grok.) */
2751 PerlIO_rewind(PL_rsfp);
2752 PerlLIO_lseek(PerlIO_fileno(PL_rsfp),(Off_t)0,0); /* just in case rewind didn't */
2753 for (which = 1; PL_origargv[which] && PL_origargv[which] != scriptname; which++) ;
2754 if (!PL_origargv[which])
2755 Perl_croak(aTHX_ "Permission denied");
2756 PL_origargv[which] = savepv(Perl_form(aTHX_ "/dev/fd/%d/%s",
2757 PerlIO_fileno(PL_rsfp), PL_origargv[which]));
2758 #if defined(HAS_FCNTL) && defined(F_SETFD)
2759 fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,0); /* ensure no close-on-exec */
2761 PerlProc_execv(Perl_form(aTHX_ "%s/perl"PERL_FS_VER_FMT, BIN_EXP,
2762 (int)PERL_REVISION, (int)PERL_VERSION,
2763 (int)PERL_SUBVERSION), PL_origargv);/* try again */
2764 Perl_croak(aTHX_ "Can't do setuid\n");
2765 #endif /* IAMSUID */
2767 if (PL_euid != PL_uid || PL_egid != PL_gid) { /* (suidperl doesn't exist, in fact) */
2768 #ifndef SETUID_SCRIPTS_ARE_SECURE_NOW
2770 PerlLIO_fstat(PerlIO_fileno(PL_rsfp),&PL_statbuf); /* may be either wrapped or real suid */
2771 if ((PL_euid != PL_uid && PL_euid == PL_statbuf.st_uid && PL_statbuf.st_mode & S_ISUID)
2773 (PL_egid != PL_gid && PL_egid == PL_statbuf.st_gid && PL_statbuf.st_mode & S_ISGID)
2776 Perl_croak(aTHX_ "YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
2777 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
2778 #endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
2779 /* not set-id, must be wrapped */
2785 S_find_beginning(pTHX)
2787 register char *s, *s2;
2789 /* skip forward in input to the real script? */
2792 while (PL_doextract) {
2793 if ((s = sv_gets(PL_linestr, PL_rsfp, 0)) == Nullch)
2794 Perl_croak(aTHX_ "No Perl script found in input\n");
2795 if (*s == '#' && s[1] == '!' && (s = instr(s,"perl"))) {
2796 PerlIO_ungetc(PL_rsfp, '\n'); /* to keep line count right */
2797 PL_doextract = FALSE;
2798 while (*s && !(isSPACE (*s) || *s == '#')) s++;
2800 while (*s == ' ' || *s == '\t') s++;
2802 while (isDIGIT(s2[-1]) || strchr("-._", s2[-1])) s2--;
2803 if (strnEQ(s2-4,"perl",4))
2805 while (s = moreswitches(s)) ;
2815 PL_uid = PerlProc_getuid();
2816 PL_euid = PerlProc_geteuid();
2817 PL_gid = PerlProc_getgid();
2818 PL_egid = PerlProc_getegid();
2820 PL_uid |= PL_gid << 16;
2821 PL_euid |= PL_egid << 16;
2823 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2827 S_forbid_setid(pTHX_ char *s)
2829 if (PL_euid != PL_uid)
2830 Perl_croak(aTHX_ "No %s allowed while running setuid", s);
2831 if (PL_egid != PL_gid)
2832 Perl_croak(aTHX_ "No %s allowed while running setgid", s);
2836 Perl_init_debugger(pTHX)
2839 HV *ostash = PL_curstash;
2841 PL_curstash = PL_debstash;
2842 PL_dbargs = GvAV(gv_AVadd((gv_fetchpv("args", GV_ADDMULTI, SVt_PVAV))));
2843 AvREAL_off(PL_dbargs);
2844 PL_DBgv = gv_fetchpv("DB", GV_ADDMULTI, SVt_PVGV);
2845 PL_DBline = gv_fetchpv("dbline", GV_ADDMULTI, SVt_PVAV);
2846 PL_DBsub = gv_HVadd(gv_fetchpv("sub", GV_ADDMULTI, SVt_PVHV));
2847 sv_upgrade(GvSV(PL_DBsub), SVt_IV); /* IVX accessed if PERLDB_SUB_NN */
2848 PL_DBsingle = GvSV((gv_fetchpv("single", GV_ADDMULTI, SVt_PV)));
2849 sv_setiv(PL_DBsingle, 0);
2850 PL_DBtrace = GvSV((gv_fetchpv("trace", GV_ADDMULTI, SVt_PV)));
2851 sv_setiv(PL_DBtrace, 0);
2852 PL_DBsignal = GvSV((gv_fetchpv("signal", GV_ADDMULTI, SVt_PV)));
2853 sv_setiv(PL_DBsignal, 0);
2854 PL_curstash = ostash;
2857 #ifndef STRESS_REALLOC
2858 #define REASONABLE(size) (size)
2860 #define REASONABLE(size) (1) /* unreasonable */
2864 Perl_init_stacks(pTHX)
2866 /* start with 128-item stack and 8K cxstack */
2867 PL_curstackinfo = new_stackinfo(REASONABLE(128),
2868 REASONABLE(8192/sizeof(PERL_CONTEXT) - 1));
2869 PL_curstackinfo->si_type = PERLSI_MAIN;
2870 PL_curstack = PL_curstackinfo->si_stack;
2871 PL_mainstack = PL_curstack; /* remember in case we switch stacks */
2873 PL_stack_base = AvARRAY(PL_curstack);
2874 PL_stack_sp = PL_stack_base;
2875 PL_stack_max = PL_stack_base + AvMAX(PL_curstack);
2877 New(50,PL_tmps_stack,REASONABLE(128),SV*);
2880 PL_tmps_max = REASONABLE(128);
2882 New(54,PL_markstack,REASONABLE(32),I32);
2883 PL_markstack_ptr = PL_markstack;
2884 PL_markstack_max = PL_markstack + REASONABLE(32);
2888 New(54,PL_scopestack,REASONABLE(32),I32);
2889 PL_scopestack_ix = 0;
2890 PL_scopestack_max = REASONABLE(32);
2892 New(54,PL_savestack,REASONABLE(128),ANY);
2893 PL_savestack_ix = 0;
2894 PL_savestack_max = REASONABLE(128);
2896 New(54,PL_retstack,REASONABLE(16),OP*);
2898 PL_retstack_max = REASONABLE(16);
2907 while (PL_curstackinfo->si_next)
2908 PL_curstackinfo = PL_curstackinfo->si_next;
2909 while (PL_curstackinfo) {
2910 PERL_SI *p = PL_curstackinfo->si_prev;
2911 /* curstackinfo->si_stack got nuked by sv_free_arenas() */
2912 Safefree(PL_curstackinfo->si_cxstack);
2913 Safefree(PL_curstackinfo);
2914 PL_curstackinfo = p;
2916 Safefree(PL_tmps_stack);
2917 Safefree(PL_markstack);
2918 Safefree(PL_scopestack);
2919 Safefree(PL_savestack);
2920 Safefree(PL_retstack);
2924 static PerlIO *tmpfp; /* moved outside init_lexer() because of UNICOS bug */
2935 lex_start(PL_linestr);
2937 PL_subname = newSVpvn("main",4);
2941 S_init_predump_symbols(pTHX)
2948 sv_setpvn(get_sv("\"", TRUE), " ", 1);
2949 PL_stdingv = gv_fetchpv("STDIN",TRUE, SVt_PVIO);
2950 GvMULTI_on(PL_stdingv);
2951 io = GvIOp(PL_stdingv);
2952 IoIFP(io) = PerlIO_stdin();
2953 tmpgv = gv_fetchpv("stdin",TRUE, SVt_PV);
2955 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io);
2957 tmpgv = gv_fetchpv("STDOUT",TRUE, SVt_PVIO);
2960 IoOFP(io) = IoIFP(io) = PerlIO_stdout();
2962 tmpgv = gv_fetchpv("stdout",TRUE, SVt_PV);
2964 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io);
2966 PL_stderrgv = gv_fetchpv("STDERR",TRUE, SVt_PVIO);
2967 GvMULTI_on(PL_stderrgv);
2968 io = GvIOp(PL_stderrgv);
2969 IoOFP(io) = IoIFP(io) = PerlIO_stderr();
2970 tmpgv = gv_fetchpv("stderr",TRUE, SVt_PV);
2972 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io);
2974 PL_statname = NEWSV(66,0); /* last filename we did stat on */
2977 PL_osname = savepv(OSNAME);
2981 S_init_postdump_symbols(pTHX_ register int argc, register char **argv, register char **env)
2988 argc--,argv++; /* skip name of script */
2989 if (PL_doswitches) {
2990 for (; argc > 0 && **argv == '-'; argc--,argv++) {
2993 if (argv[0][1] == '-' && !argv[0][2]) {
2997 if (s = strchr(argv[0], '=')) {
2999 sv_setpv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),s);
3002 sv_setiv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),1);
3005 PL_toptarget = NEWSV(0,0);
3006 sv_upgrade(PL_toptarget, SVt_PVFM);
3007 sv_setpvn(PL_toptarget, "", 0);
3008 PL_bodytarget = NEWSV(0,0);
3009 sv_upgrade(PL_bodytarget, SVt_PVFM);
3010 sv_setpvn(PL_bodytarget, "", 0);
3011 PL_formtarget = PL_bodytarget;
3014 if (tmpgv = gv_fetchpv("0",TRUE, SVt_PV)) {
3015 sv_setpv(GvSV(tmpgv),PL_origfilename);
3016 magicname("0", "0", 1);
3018 if (tmpgv = gv_fetchpv("\030",TRUE, SVt_PV))
3020 sv_setpv(GvSV(tmpgv), os2_execname());
3022 sv_setpv(GvSV(tmpgv),PL_origargv[0]);
3024 if (PL_argvgv = gv_fetchpv("ARGV",TRUE, SVt_PVAV)) {
3025 GvMULTI_on(PL_argvgv);
3026 (void)gv_AVadd(PL_argvgv);
3027 av_clear(GvAVn(PL_argvgv));
3028 for (; argc > 0; argc--,argv++) {
3029 av_push(GvAVn(PL_argvgv),newSVpv(argv[0],0));
3032 if (PL_envgv = gv_fetchpv("ENV",TRUE, SVt_PVHV)) {
3034 GvMULTI_on(PL_envgv);
3035 hv = GvHVn(PL_envgv);
3036 hv_magic(hv, PL_envgv, 'E');
3037 #if !defined( VMS) && !defined(EPOC) /* VMS doesn't have environ array */
3038 /* Note that if the supplied env parameter is actually a copy
3039 of the global environ then it may now point to free'd memory
3040 if the environment has been modified since. To avoid this
3041 problem we treat env==NULL as meaning 'use the default'
3046 environ[0] = Nullch;
3047 for (; *env; env++) {
3048 if (!(s = strchr(*env,'=')))
3054 sv = newSVpv(s--,0);
3055 (void)hv_store(hv, *env, s - *env, sv, 0);
3057 #if defined(__BORLANDC__) && defined(USE_WIN32_RTL_ENV)
3058 /* Sins of the RTL. See note in my_setenv(). */
3059 (void)PerlEnv_putenv(savepv(*env));
3063 #ifdef DYNAMIC_ENV_FETCH
3064 HvNAME(hv) = savepv(ENV_HV_NAME);
3068 if (tmpgv = gv_fetchpv("$",TRUE, SVt_PV))
3069 sv_setiv(GvSV(tmpgv), (IV)PerlProc_getpid());
3073 S_init_perllib(pTHX)
3078 s = PerlEnv_getenv("PERL5LIB");
3082 incpush(PerlEnv_getenv("PERLLIB"), FALSE);
3084 /* Treat PERL5?LIB as a possible search list logical name -- the
3085 * "natural" VMS idiom for a Unix path string. We allow each
3086 * element to be a set of |-separated directories for compatibility.
3090 if (my_trnlnm("PERL5LIB",buf,0))
3091 do { incpush(buf,TRUE); } while (my_trnlnm("PERL5LIB",buf,++idx));
3093 while (my_trnlnm("PERLLIB",buf,idx++)) incpush(buf,FALSE);
3097 /* Use the ~-expanded versions of APPLLIB (undocumented),
3098 ARCHLIB PRIVLIB SITEARCH and SITELIB
3101 incpush(APPLLIB_EXP, TRUE);
3105 incpush(ARCHLIB_EXP, FALSE);
3108 #define PRIVLIB_EXP "/usr/local/lib/perl5:/usr/local/lib/perl"
3111 incpush(PRIVLIB_EXP, TRUE);
3113 incpush(PRIVLIB_EXP, FALSE);
3118 char *path = SITELIB_EXP;
3123 if (strrchr(buf,'/')) /* XXX Hack, Configure var needed */
3124 *strrchr(buf,'/') = '\0';
3129 #if defined(PERL_VENDORLIB_EXP)
3131 incpush(PERL_VENDORLIB_EXP, TRUE);
3133 incpush(PERL_VENDORLIB_EXP, FALSE);
3137 incpush(".", FALSE);
3141 # define PERLLIB_SEP ';'
3144 # define PERLLIB_SEP '|'
3146 # define PERLLIB_SEP ':'
3149 #ifndef PERLLIB_MANGLE
3150 # define PERLLIB_MANGLE(s,n) (s)
3154 S_incpush(pTHX_ char *p, int addsubdirs)
3156 SV *subdir = Nullsv;
3162 subdir = sv_newmortal();
3165 /* Break at all separators */
3167 SV *libdir = NEWSV(55,0);
3170 /* skip any consecutive separators */
3171 while ( *p == PERLLIB_SEP ) {
3172 /* Uncomment the next line for PATH semantics */
3173 /* av_push(GvAVn(PL_incgv), newSVpvn(".", 1)); */
3177 if ( (s = strchr(p, PERLLIB_SEP)) != Nullch ) {
3178 sv_setpvn(libdir, PERLLIB_MANGLE(p, (STRLEN)(s - p)),
3183 sv_setpv(libdir, PERLLIB_MANGLE(p, 0));
3184 p = Nullch; /* break out */
3188 * BEFORE pushing libdir onto @INC we may first push version- and
3189 * archname-specific sub-directories.
3192 #ifdef PERL_INC_VERSION_LIST
3193 /* Configure terminates PERL_INC_VERSION_LIST with a NULL */
3194 const char *incverlist[] = { PERL_INC_VERSION_LIST };
3195 const char **incver;
3197 struct stat tmpstatbuf;
3202 if ((unix = tounixspec_ts(SvPV(libdir,len),Nullch)) != Nullch) {
3204 while (unix[len-1] == '/') len--; /* Cosmetic */
3205 sv_usepvn(libdir,unix,len);
3208 PerlIO_printf(Perl_error_log,
3209 "Failed to unixify @INC element \"%s\"\n",
3212 /* .../version/archname if -d .../version/archname */
3213 Perl_sv_setpvf(aTHX_ subdir, "%"SVf"/"PERL_FS_VER_FMT"/%s", libdir,
3214 (int)PERL_REVISION, (int)PERL_VERSION,
3215 (int)PERL_SUBVERSION, ARCHNAME);
3216 if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
3217 S_ISDIR(tmpstatbuf.st_mode))
3218 av_push(GvAVn(PL_incgv), newSVsv(subdir));
3220 /* .../version if -d .../version */
3221 Perl_sv_setpvf(aTHX_ subdir, "%"SVf"/"PERL_FS_VER_FMT, libdir,
3222 (int)PERL_REVISION, (int)PERL_VERSION,
3223 (int)PERL_SUBVERSION);
3224 if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
3225 S_ISDIR(tmpstatbuf.st_mode))
3226 av_push(GvAVn(PL_incgv), newSVsv(subdir));
3228 #ifdef PERL_INC_VERSION_LIST
3229 for (incver = incverlist; *incver; incver++) {
3230 /* .../xxx if -d .../xxx */
3231 Perl_sv_setpvf(aTHX_ subdir, "%"SVf"/%s", libdir, *incver);
3232 if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
3233 S_ISDIR(tmpstatbuf.st_mode))
3234 av_push(GvAVn(PL_incgv), newSVsv(subdir));
3239 /* finally push this lib directory on the end of @INC */
3240 av_push(GvAVn(PL_incgv), libdir);
3245 STATIC struct perl_thread *
3246 S_init_main_thread(pTHX)
3248 #if !defined(PERL_IMPLICIT_CONTEXT)
3249 struct perl_thread *thr;
3253 Newz(53, thr, 1, struct perl_thread);
3254 PL_curcop = &PL_compiling;
3255 thr->interp = PERL_GET_INTERP;
3256 thr->cvcache = newHV();
3257 thr->threadsv = newAV();
3258 /* thr->threadsvp is set when find_threadsv is called */
3259 thr->specific = newAV();
3260 thr->flags = THRf_R_JOINABLE;
3261 MUTEX_INIT(&thr->mutex);
3262 /* Handcraft thrsv similarly to mess_sv */
3263 New(53, PL_thrsv, 1, SV);
3264 Newz(53, xpv, 1, XPV);
3265 SvFLAGS(PL_thrsv) = SVt_PV;
3266 SvANY(PL_thrsv) = (void*)xpv;
3267 SvREFCNT(PL_thrsv) = 1 << 30; /* practically infinite */
3268 SvPVX(PL_thrsv) = (char*)thr;
3269 SvCUR_set(PL_thrsv, sizeof(thr));
3270 SvLEN_set(PL_thrsv, sizeof(thr));
3271 *SvEND(PL_thrsv) = '\0'; /* in the trailing_nul field */
3272 thr->oursv = PL_thrsv;
3273 PL_chopset = " \n-";
3276 MUTEX_LOCK(&PL_threads_mutex);
3281 MUTEX_UNLOCK(&PL_threads_mutex);
3283 #ifdef HAVE_THREAD_INTERN
3284 Perl_init_thread_intern(thr);
3287 #ifdef SET_THREAD_SELF
3288 SET_THREAD_SELF(thr);
3290 thr->self = pthread_self();
3291 #endif /* SET_THREAD_SELF */
3295 * These must come after the SET_THR because sv_setpvn does
3296 * SvTAINT and the taint fields require dTHR.
3298 PL_toptarget = NEWSV(0,0);
3299 sv_upgrade(PL_toptarget, SVt_PVFM);
3300 sv_setpvn(PL_toptarget, "", 0);
3301 PL_bodytarget = NEWSV(0,0);
3302 sv_upgrade(PL_bodytarget, SVt_PVFM);
3303 sv_setpvn(PL_bodytarget, "", 0);
3304 PL_formtarget = PL_bodytarget;
3305 thr->errsv = newSVpvn("", 0);
3306 (void) find_threadsv("@"); /* Ensure $@ is initialised early */
3309 PL_regcompp = MEMBER_TO_FPTR(Perl_pregcomp);
3310 PL_regexecp = MEMBER_TO_FPTR(Perl_regexec_flags);
3311 PL_regint_start = MEMBER_TO_FPTR(Perl_re_intuit_start);
3312 PL_regint_string = MEMBER_TO_FPTR(Perl_re_intuit_string);
3313 PL_regfree = MEMBER_TO_FPTR(Perl_pregfree);
3315 PL_reginterp_cnt = 0;
3319 #endif /* USE_THREADS */
3322 Perl_call_list(pTHX_ I32 oldscope, AV *paramList)
3326 line_t oldline = CopLINE(PL_curcop);
3332 while (AvFILL(paramList) >= 0) {
3333 cv = (CV*)av_shift(paramList);
3335 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_call_list_body), cv);
3339 (void)SvPV(atsv, len);
3342 PL_curcop = &PL_compiling;
3343 CopLINE_set(PL_curcop, oldline);
3344 if (paramList == PL_beginav)
3345 sv_catpv(atsv, "BEGIN failed--compilation aborted");
3347 Perl_sv_catpvf(aTHX_ atsv,
3348 "%s failed--call queue aborted",
3349 paramList == PL_checkav ? "CHECK"
3350 : paramList == PL_initav ? "INIT"
3352 while (PL_scopestack_ix > oldscope)
3354 Perl_croak(aTHX_ "%s", SvPVx(atsv, n_a));
3361 /* my_exit() was called */
3362 while (PL_scopestack_ix > oldscope)
3365 PL_curstash = PL_defstash;
3366 PL_curcop = &PL_compiling;
3367 CopLINE_set(PL_curcop, oldline);
3368 if (PL_statusvalue && !(PL_exit_flags & PERL_EXIT_EXPECTED)) {
3369 if (paramList == PL_beginav)
3370 Perl_croak(aTHX_ "BEGIN failed--compilation aborted");
3372 Perl_croak(aTHX_ "%s failed--call queue aborted",
3373 paramList == PL_checkav ? "CHECK"
3374 : paramList == PL_initav ? "INIT"
3381 PL_curcop = &PL_compiling;
3382 CopLINE_set(PL_curcop, oldline);
3385 PerlIO_printf(Perl_error_log, "panic: restartop\n");
3393 S_call_list_body(pTHX_ va_list args)
3396 CV *cv = va_arg(args, CV*);
3398 PUSHMARK(PL_stack_sp);
3399 call_sv((SV*)cv, G_EVAL|G_DISCARD);
3404 Perl_my_exit(pTHX_ U32 status)
3408 DEBUG_S(PerlIO_printf(Perl_debug_log, "my_exit: thread %p, status %lu\n",
3409 thr, (unsigned long) status));
3418 STATUS_NATIVE_SET(status);
3425 Perl_my_failure_exit(pTHX)
3428 if (vaxc$errno & 1) {
3429 if (STATUS_NATIVE & 1) /* fortuitiously includes "-1" */
3430 STATUS_NATIVE_SET(44);
3433 if (!vaxc$errno && errno) /* unlikely */
3434 STATUS_NATIVE_SET(44);
3436 STATUS_NATIVE_SET(vaxc$errno);
3441 STATUS_POSIX_SET(errno);
3443 exitstatus = STATUS_POSIX >> 8;
3444 if (exitstatus & 255)
3445 STATUS_POSIX_SET(exitstatus);
3447 STATUS_POSIX_SET(255);
3454 S_my_exit_jump(pTHX)
3457 register PERL_CONTEXT *cx;
3462 SvREFCNT_dec(PL_e_script);
3463 PL_e_script = Nullsv;
3466 POPSTACK_TO(PL_mainstack);
3467 if (cxstack_ix >= 0) {
3470 POPBLOCK(cx,PL_curpm);
3482 read_e_script(pTHXo_ int idx, SV *buf_sv, int maxlen)
3485 p = SvPVX(PL_e_script);
3486 nl = strchr(p, '\n');
3487 nl = (nl) ? nl+1 : SvEND(PL_e_script);
3489 filter_del(read_e_script);
3492 sv_catpvn(buf_sv, p, nl-p);
3493 sv_chop(PL_e_script, nl);