3 * Copyright (c) 1987-2002 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 */
21 char *nw_get_sitelib(const char *pl);
24 /* XXX If this causes problems, set i_unistd=undef in the hint file. */
41 #if !defined(STANDARD_C) && !defined(HAS_GETENV_PROTOTYPE) && !defined(PERL_MICRO)
42 char *getenv (char *); /* Usually in <stdlib.h> */
45 static I32 read_e_script(pTHX_ int idx, SV *buf_sv, int maxlen);
53 #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
59 #if defined(USE_5005THREADS)
60 # define INIT_TLS_AND_INTERP \
62 if (!PL_curinterp) { \
63 PERL_SET_INTERP(my_perl); \
69 # if defined(USE_ITHREADS)
70 # define INIT_TLS_AND_INTERP \
72 if (!PL_curinterp) { \
73 PERL_SET_INTERP(my_perl); \
76 PERL_SET_THX(my_perl); \
80 PERL_SET_THX(my_perl); \
84 # define INIT_TLS_AND_INTERP \
86 if (!PL_curinterp) { \
87 PERL_SET_INTERP(my_perl); \
89 PERL_SET_THX(my_perl); \
94 #ifdef PERL_IMPLICIT_SYS
96 perl_alloc_using(struct IPerlMem* ipM, struct IPerlMem* ipMS,
97 struct IPerlMem* ipMP, struct IPerlEnv* ipE,
98 struct IPerlStdIO* ipStd, struct IPerlLIO* ipLIO,
99 struct IPerlDir* ipD, struct IPerlSock* ipS,
100 struct IPerlProc* ipP)
102 PerlInterpreter *my_perl;
103 /* New() needs interpreter, so call malloc() instead */
104 my_perl = (PerlInterpreter*)(*ipM->pMalloc)(ipM, sizeof(PerlInterpreter));
106 Zero(my_perl, 1, PerlInterpreter);
122 =head1 Embedding Functions
124 =for apidoc perl_alloc
126 Allocates a new Perl interpreter. See L<perlembed>.
134 PerlInterpreter *my_perl;
135 #ifdef USE_5005THREADS
139 /* New() needs interpreter, so call malloc() instead */
140 my_perl = (PerlInterpreter*)PerlMem_malloc(sizeof(PerlInterpreter));
143 Zero(my_perl, 1, PerlInterpreter);
146 #endif /* PERL_IMPLICIT_SYS */
149 =for apidoc perl_construct
151 Initializes a new Perl interpreter. See L<perlembed>.
157 perl_construct(pTHXx)
159 #ifdef USE_5005THREADS
161 struct perl_thread *thr = NULL;
162 #endif /* FAKE_THREADS */
163 #endif /* USE_5005THREADS */
167 PL_perl_destruct_level = 1;
169 if (PL_perl_destruct_level > 0)
173 /* Init the real globals (and main thread)? */
175 #ifdef USE_5005THREADS
176 MUTEX_INIT(&PL_sv_mutex);
178 * Safe to use basic SV functions from now on (though
179 * not things like mortals or tainting yet).
181 MUTEX_INIT(&PL_eval_mutex);
182 COND_INIT(&PL_eval_cond);
183 MUTEX_INIT(&PL_threads_mutex);
184 COND_INIT(&PL_nthreads_cond);
185 # ifdef EMULATE_ATOMIC_REFCOUNTS
186 MUTEX_INIT(&PL_svref_mutex);
187 # endif /* EMULATE_ATOMIC_REFCOUNTS */
189 MUTEX_INIT(&PL_cred_mutex);
190 MUTEX_INIT(&PL_sv_lock_mutex);
191 MUTEX_INIT(&PL_fdpid_mutex);
193 thr = init_main_thread();
194 #endif /* USE_5005THREADS */
196 #ifdef PERL_FLEXIBLE_EXCEPTIONS
197 PL_protect = MEMBER_TO_FPTR(Perl_default_protect); /* for exceptions */
200 PL_curcop = &PL_compiling; /* needed by ckWARN, right away */
202 PL_linestr = NEWSV(65,79);
203 sv_upgrade(PL_linestr,SVt_PVIV);
205 if (!SvREADONLY(&PL_sv_undef)) {
206 /* set read-only and try to insure than we wont see REFCNT==0
209 SvREADONLY_on(&PL_sv_undef);
210 SvREFCNT(&PL_sv_undef) = (~(U32)0)/2;
212 sv_setpv(&PL_sv_no,PL_No);
214 SvREADONLY_on(&PL_sv_no);
215 SvREFCNT(&PL_sv_no) = (~(U32)0)/2;
217 sv_setpv(&PL_sv_yes,PL_Yes);
219 SvREADONLY_on(&PL_sv_yes);
220 SvREFCNT(&PL_sv_yes) = (~(U32)0)/2;
223 PL_sighandlerp = Perl_sighandler;
224 PL_pidstatus = newHV();
227 PL_rs = newSVpvn("\n", 1);
232 PL_lex_state = LEX_NOTPARSING;
238 SET_NUMERIC_STANDARD();
242 PL_patchlevel = NEWSV(0,4);
243 (void)SvUPGRADE(PL_patchlevel, SVt_PVNV);
244 if (PERL_REVISION > 127 || PERL_VERSION > 127 || PERL_SUBVERSION > 127)
245 SvGROW(PL_patchlevel, UTF8_MAXLEN*3+1);
246 s = (U8*)SvPVX(PL_patchlevel);
247 /* Build version strings using "native" characters */
248 s = uvchr_to_utf8(s, (UV)PERL_REVISION);
249 s = uvchr_to_utf8(s, (UV)PERL_VERSION);
250 s = uvchr_to_utf8(s, (UV)PERL_SUBVERSION);
252 SvCUR_set(PL_patchlevel, s - (U8*)SvPVX(PL_patchlevel));
253 SvPOK_on(PL_patchlevel);
254 SvNVX(PL_patchlevel) = (NV)PERL_REVISION
255 + ((NV)PERL_VERSION / (NV)1000)
256 #if defined(PERL_SUBVERSION) && PERL_SUBVERSION > 0
257 + ((NV)PERL_SUBVERSION / (NV)1000000)
260 SvNOK_on(PL_patchlevel); /* dual valued */
261 SvUTF8_on(PL_patchlevel);
262 SvREADONLY_on(PL_patchlevel);
265 #if defined(LOCAL_PATCH_COUNT)
266 PL_localpatches = local_patches; /* For possible -v */
269 #ifdef HAVE_INTERP_INTERN
273 PerlIO_init(aTHX); /* Hook to IO system */
275 PL_fdpid = newAV(); /* for remembering popen pids by fd */
276 PL_modglobal = newHV(); /* pointers to per-interpreter module globals */
277 PL_errors = newSVpvn("",0);
278 sv_setpvn(PERL_DEBUG_PAD(0), "", 0); /* For regex debugging. */
279 sv_setpvn(PERL_DEBUG_PAD(1), "", 0); /* ext/re needs these */
280 sv_setpvn(PERL_DEBUG_PAD(2), "", 0); /* even without DEBUGGING. */
282 PL_regex_padav = newAV();
283 av_push(PL_regex_padav,(SV*)newAV()); /* First entry is an array of empty elements */
284 PL_regex_pad = AvARRAY(PL_regex_padav);
286 #ifdef USE_REENTRANT_API
287 Perl_reentrant_init(aTHX);
290 /* Note that strtab is a rather special HV. Assumptions are made
291 about not iterating on it, and not adding tie magic to it.
292 It is properly deallocated in perl_destruct() */
295 #ifdef USE_5005THREADS
296 MUTEX_INIT(&PL_strtab_mutex);
298 HvSHAREKEYS_off(PL_strtab); /* mandatory */
299 hv_ksplit(PL_strtab, 512);
301 #if defined(__DYNAMIC__) && (defined(NeXT) || defined(__NeXT__))
302 _dyld_lookup_and_bind
303 ("__environ", (unsigned long *) &environ_pointer, NULL);
306 #ifdef USE_ENVIRON_ARRAY
307 PL_origenviron = environ;
310 /* Use sysconf(_SC_CLK_TCK) if available, if not
311 * available or if the sysconf() fails, use the HZ. */
312 #if defined(HAS_SYSCONF) && defined(_SC_CLK_TCK)
313 PL_clocktick = sysconf(_SC_CLK_TCK);
314 if (PL_clocktick <= 0)
322 =for apidoc nothreadhook
324 Stub that provides thread hook for perl_destruct when there are
331 Perl_nothreadhook(pTHX)
337 =for apidoc perl_destruct
339 Shuts down a Perl interpreter. See L<perlembed>.
347 volatile int destruct_level; /* 0=none, 1=full, 2=full with checks */
349 #ifdef USE_5005THREADS
352 #endif /* USE_5005THREADS */
354 /* wait for all pseudo-forked children to finish */
355 PERL_WAIT_FOR_CHILDREN;
357 #ifdef USE_5005THREADS
359 /* Pass 1 on any remaining threads: detach joinables, join zombies */
361 MUTEX_LOCK(&PL_threads_mutex);
362 DEBUG_S(PerlIO_printf(Perl_debug_log,
363 "perl_destruct: waiting for %d threads...\n",
365 for (t = thr->next; t != thr; t = t->next) {
366 MUTEX_LOCK(&t->mutex);
367 switch (ThrSTATE(t)) {
370 DEBUG_S(PerlIO_printf(Perl_debug_log,
371 "perl_destruct: joining zombie %p\n", t));
372 ThrSETSTATE(t, THRf_DEAD);
373 MUTEX_UNLOCK(&t->mutex);
376 * The SvREFCNT_dec below may take a long time (e.g. av
377 * may contain an object scalar whose destructor gets
378 * called) so we have to unlock threads_mutex and start
381 MUTEX_UNLOCK(&PL_threads_mutex);
383 SvREFCNT_dec((SV*)av);
384 DEBUG_S(PerlIO_printf(Perl_debug_log,
385 "perl_destruct: joined zombie %p OK\n", t));
387 case THRf_R_JOINABLE:
388 DEBUG_S(PerlIO_printf(Perl_debug_log,
389 "perl_destruct: detaching thread %p\n", t));
390 ThrSETSTATE(t, THRf_R_DETACHED);
392 * We unlock threads_mutex and t->mutex in the opposite order
393 * from which we locked them just so that DETACH won't
394 * deadlock if it panics. It's only a breach of good style
395 * not a bug since they are unlocks not locks.
397 MUTEX_UNLOCK(&PL_threads_mutex);
399 MUTEX_UNLOCK(&t->mutex);
402 DEBUG_S(PerlIO_printf(Perl_debug_log,
403 "perl_destruct: ignoring %p (state %u)\n",
405 MUTEX_UNLOCK(&t->mutex);
406 /* fall through and out */
409 /* We leave the above "Pass 1" loop with threads_mutex still locked */
411 /* Pass 2 on remaining threads: wait for the thread count to drop to one */
412 while (PL_nthreads > 1)
414 DEBUG_S(PerlIO_printf(Perl_debug_log,
415 "perl_destruct: final wait for %d threads\n",
417 COND_WAIT(&PL_nthreads_cond, &PL_threads_mutex);
419 /* At this point, we're the last thread */
420 MUTEX_UNLOCK(&PL_threads_mutex);
421 DEBUG_S(PerlIO_printf(Perl_debug_log, "perl_destruct: armageddon has arrived\n"));
422 MUTEX_DESTROY(&PL_threads_mutex);
423 COND_DESTROY(&PL_nthreads_cond);
425 #endif /* !defined(FAKE_THREADS) */
426 #endif /* USE_5005THREADS */
428 destruct_level = PL_perl_destruct_level;
432 if ((s = PerlEnv_getenv("PERL_DESTRUCT_LEVEL"))) {
434 if (destruct_level < i)
441 if(PL_exit_flags & PERL_EXIT_DESTRUCT_END) {
446 if (PL_endav && !PL_minus_c)
447 call_list(PL_scopestack_ix, PL_endav);
453 /* Need to flush since END blocks can produce output */
456 if (CALL_FPTR(PL_threadhook)(aTHX)) {
457 /* Threads hook has vetoed further cleanup */
458 return STATUS_NATIVE_EXPORT;
461 /* We must account for everything. */
463 /* Destroy the main CV and syntax tree */
465 /* If running under -d may not have PL_comppad. */
466 PL_curpad = PL_comppad ? AvARRAY(PL_comppad) : NULL;
467 op_free(PL_main_root);
468 PL_main_root = Nullop;
470 PL_curcop = &PL_compiling;
471 PL_main_start = Nullop;
472 SvREFCNT_dec(PL_main_cv);
476 /* Tell PerlIO we are about to tear things apart in case
477 we have layers which are using resources that should
481 PerlIO_destruct(aTHX);
483 if (PL_sv_objcount) {
485 * Try to destruct global references. We do this first so that the
486 * destructors and destructees still exist. Some sv's might remain.
487 * Non-referenced objects are on their own.
492 /* unhook hooks which will soon be, or use, destroyed data */
493 SvREFCNT_dec(PL_warnhook);
494 PL_warnhook = Nullsv;
495 SvREFCNT_dec(PL_diehook);
498 /* call exit list functions */
499 while (PL_exitlistlen-- > 0)
500 PL_exitlist[PL_exitlistlen].fn(aTHX_ PL_exitlist[PL_exitlistlen].ptr);
502 Safefree(PL_exitlist);
504 if (destruct_level == 0){
506 DEBUG_P(debprofdump());
508 #if defined(PERLIO_LAYERS)
509 /* No more IO - including error messages ! */
510 PerlIO_cleanup(aTHX);
513 /* The exit() function will do everything that needs doing. */
514 return STATUS_NATIVE_EXPORT;
517 /* jettison our possibly duplicated environment */
518 /* if PERL_USE_SAFE_PUTENV is defined environ will not have been copied
519 * so we certainly shouldn't free it here
521 #if defined(USE_ENVIRON_ARRAY) && !defined(PERL_USE_SAFE_PUTENV)
522 if (environ != PL_origenviron
524 /* only main thread can free environ[0] contents */
525 && PL_curinterp == aTHX
531 for (i = 0; environ[i]; i++)
532 safesysfree(environ[i]);
534 /* Must use safesysfree() when working with environ. */
535 safesysfree(environ);
537 environ = PL_origenviron;
542 /* the syntax tree is shared between clones
543 * so op_free(PL_main_root) only ReREFCNT_dec's
544 * REGEXPs in the parent interpreter
545 * we need to manually ReREFCNT_dec for the clones
548 I32 i = AvFILLp(PL_regex_padav) + 1;
549 SV **ary = AvARRAY(PL_regex_padav);
553 REGEXP *re = INT2PTR(REGEXP *,SvIVX(resv));
555 if (SvFLAGS(resv) & SVf_BREAK) {
556 /* this is PL_reg_curpm, already freed
557 * flag is set in regexec.c:S_regtry
559 SvFLAGS(resv) &= ~SVf_BREAK;
561 else if(SvREPADTMP(resv)) {
562 SvREPADTMP_off(resv);
569 SvREFCNT_dec(PL_regex_padav);
570 PL_regex_padav = Nullav;
574 /* loosen bonds of global variables */
577 (void)PerlIO_close(PL_rsfp);
581 /* Filters for program text */
582 SvREFCNT_dec(PL_rsfp_filters);
583 PL_rsfp_filters = Nullav;
586 PL_preprocess = FALSE;
592 PL_doswitches = FALSE;
593 PL_dowarn = G_WARN_OFF;
594 PL_doextract = FALSE;
595 PL_sawampersand = FALSE; /* must save all match strings */
598 Safefree(PL_inplace);
600 SvREFCNT_dec(PL_patchlevel);
603 SvREFCNT_dec(PL_e_script);
604 PL_e_script = Nullsv;
607 while (--PL_origargc >= 0) {
608 Safefree(PL_origargv[PL_origargc]);
610 Safefree(PL_origargv);
612 /* magical thingies */
614 SvREFCNT_dec(PL_ofs_sv); /* $, */
617 SvREFCNT_dec(PL_ors_sv); /* $\ */
620 SvREFCNT_dec(PL_rs); /* $/ */
623 PL_multiline = 0; /* $* */
624 Safefree(PL_osname); /* $^O */
627 SvREFCNT_dec(PL_statname);
628 PL_statname = Nullsv;
631 /* defgv, aka *_ should be taken care of elsewhere */
633 /* clean up after study() */
634 SvREFCNT_dec(PL_lastscream);
635 PL_lastscream = Nullsv;
636 Safefree(PL_screamfirst);
638 Safefree(PL_screamnext);
642 Safefree(PL_efloatbuf);
643 PL_efloatbuf = Nullch;
646 /* startup and shutdown function lists */
647 SvREFCNT_dec(PL_beginav);
648 SvREFCNT_dec(PL_beginav_save);
649 SvREFCNT_dec(PL_endav);
650 SvREFCNT_dec(PL_checkav);
651 SvREFCNT_dec(PL_checkav_save);
652 SvREFCNT_dec(PL_initav);
654 PL_beginav_save = Nullav;
657 PL_checkav_save = Nullav;
660 /* shortcuts just get cleared */
666 PL_argvoutgv = Nullgv;
668 PL_stderrgv = Nullgv;
669 PL_last_in_gv = Nullgv;
671 PL_debstash = Nullhv;
673 /* reset so print() ends up where we expect */
676 SvREFCNT_dec(PL_argvout_stack);
677 PL_argvout_stack = Nullav;
679 SvREFCNT_dec(PL_modglobal);
680 PL_modglobal = Nullhv;
681 SvREFCNT_dec(PL_preambleav);
682 PL_preambleav = Nullav;
683 SvREFCNT_dec(PL_subname);
685 SvREFCNT_dec(PL_linestr);
687 SvREFCNT_dec(PL_pidstatus);
688 PL_pidstatus = Nullhv;
689 SvREFCNT_dec(PL_toptarget);
690 PL_toptarget = Nullsv;
691 SvREFCNT_dec(PL_bodytarget);
692 PL_bodytarget = Nullsv;
693 PL_formtarget = Nullsv;
695 /* free locale stuff */
696 #ifdef USE_LOCALE_COLLATE
697 Safefree(PL_collation_name);
698 PL_collation_name = Nullch;
701 #ifdef USE_LOCALE_NUMERIC
702 Safefree(PL_numeric_name);
703 PL_numeric_name = Nullch;
704 SvREFCNT_dec(PL_numeric_radix_sv);
707 /* clear utf8 character classes */
708 SvREFCNT_dec(PL_utf8_alnum);
709 SvREFCNT_dec(PL_utf8_alnumc);
710 SvREFCNT_dec(PL_utf8_ascii);
711 SvREFCNT_dec(PL_utf8_alpha);
712 SvREFCNT_dec(PL_utf8_space);
713 SvREFCNT_dec(PL_utf8_cntrl);
714 SvREFCNT_dec(PL_utf8_graph);
715 SvREFCNT_dec(PL_utf8_digit);
716 SvREFCNT_dec(PL_utf8_upper);
717 SvREFCNT_dec(PL_utf8_lower);
718 SvREFCNT_dec(PL_utf8_print);
719 SvREFCNT_dec(PL_utf8_punct);
720 SvREFCNT_dec(PL_utf8_xdigit);
721 SvREFCNT_dec(PL_utf8_mark);
722 SvREFCNT_dec(PL_utf8_toupper);
723 SvREFCNT_dec(PL_utf8_totitle);
724 SvREFCNT_dec(PL_utf8_tolower);
725 SvREFCNT_dec(PL_utf8_tofold);
726 SvREFCNT_dec(PL_utf8_idstart);
727 SvREFCNT_dec(PL_utf8_idcont);
728 PL_utf8_alnum = Nullsv;
729 PL_utf8_alnumc = Nullsv;
730 PL_utf8_ascii = Nullsv;
731 PL_utf8_alpha = Nullsv;
732 PL_utf8_space = Nullsv;
733 PL_utf8_cntrl = Nullsv;
734 PL_utf8_graph = Nullsv;
735 PL_utf8_digit = Nullsv;
736 PL_utf8_upper = Nullsv;
737 PL_utf8_lower = Nullsv;
738 PL_utf8_print = Nullsv;
739 PL_utf8_punct = Nullsv;
740 PL_utf8_xdigit = Nullsv;
741 PL_utf8_mark = Nullsv;
742 PL_utf8_toupper = Nullsv;
743 PL_utf8_totitle = Nullsv;
744 PL_utf8_tolower = Nullsv;
745 PL_utf8_tofold = Nullsv;
746 PL_utf8_idstart = Nullsv;
747 PL_utf8_idcont = Nullsv;
749 if (!specialWARN(PL_compiling.cop_warnings))
750 SvREFCNT_dec(PL_compiling.cop_warnings);
751 PL_compiling.cop_warnings = Nullsv;
752 if (!specialCopIO(PL_compiling.cop_io))
753 SvREFCNT_dec(PL_compiling.cop_io);
754 PL_compiling.cop_io = Nullsv;
755 CopFILE_free(&PL_compiling);
756 CopSTASH_free(&PL_compiling);
758 /* Prepare to destruct main symbol table. */
763 SvREFCNT_dec(PL_curstname);
764 PL_curstname = Nullsv;
766 /* clear queued errors */
767 SvREFCNT_dec(PL_errors);
771 if (destruct_level >= 2 && ckWARN_d(WARN_INTERNAL)) {
772 if (PL_scopestack_ix != 0)
773 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
774 "Unbalanced scopes: %ld more ENTERs than LEAVEs\n",
775 (long)PL_scopestack_ix);
776 if (PL_savestack_ix != 0)
777 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
778 "Unbalanced saves: %ld more saves than restores\n",
779 (long)PL_savestack_ix);
780 if (PL_tmps_floor != -1)
781 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Unbalanced tmps: %ld more allocs than frees\n",
782 (long)PL_tmps_floor + 1);
783 if (cxstack_ix != -1)
784 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Unbalanced context: %ld more PUSHes than POPs\n",
785 (long)cxstack_ix + 1);
788 /* Now absolutely destruct everything, somehow or other, loops or no. */
789 SvFLAGS(PL_fdpid) |= SVTYPEMASK; /* don't clean out pid table now */
790 SvFLAGS(PL_strtab) |= SVTYPEMASK; /* don't clean out strtab now */
792 /* the 2 is for PL_fdpid and PL_strtab */
793 while (PL_sv_count > 2 && sv_clean_all())
796 SvFLAGS(PL_fdpid) &= ~SVTYPEMASK;
797 SvFLAGS(PL_fdpid) |= SVt_PVAV;
798 SvFLAGS(PL_strtab) &= ~SVTYPEMASK;
799 SvFLAGS(PL_strtab) |= SVt_PVHV;
801 AvREAL_off(PL_fdpid); /* no surviving entries */
802 SvREFCNT_dec(PL_fdpid); /* needed in io_close() */
805 #ifdef HAVE_INTERP_INTERN
809 /* Destruct the global string table. */
811 /* Yell and reset the HeVAL() slots that are still holding refcounts,
812 * so that sv_free() won't fail on them.
820 max = HvMAX(PL_strtab);
821 array = HvARRAY(PL_strtab);
824 if (hent && ckWARN_d(WARN_INTERNAL)) {
825 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
826 "Unbalanced string table refcount: (%d) for \"%s\"",
827 HeVAL(hent) - Nullsv, HeKEY(hent));
828 HeVAL(hent) = Nullsv;
838 SvREFCNT_dec(PL_strtab);
841 /* free the pointer table used for cloning */
842 ptr_table_free(PL_ptr_table);
845 /* free special SVs */
847 SvREFCNT(&PL_sv_yes) = 0;
848 sv_clear(&PL_sv_yes);
849 SvANY(&PL_sv_yes) = NULL;
850 SvFLAGS(&PL_sv_yes) = 0;
852 SvREFCNT(&PL_sv_no) = 0;
854 SvANY(&PL_sv_no) = NULL;
855 SvFLAGS(&PL_sv_no) = 0;
859 for (i=0; i<=2; i++) {
860 SvREFCNT(PERL_DEBUG_PAD(i)) = 0;
861 sv_clear(PERL_DEBUG_PAD(i));
862 SvANY(PERL_DEBUG_PAD(i)) = NULL;
863 SvFLAGS(PERL_DEBUG_PAD(i)) = 0;
867 if (PL_sv_count != 0 && ckWARN_d(WARN_INTERNAL))
868 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Scalars leaked: %ld\n", (long)PL_sv_count);
870 #if defined(PERLIO_LAYERS)
871 /* No more IO - including error messages ! */
872 PerlIO_cleanup(aTHX);
875 /* sv_undef needs to stay immortal until after PerlIO_cleanup
876 as currently layers use it rather than Nullsv as a marker
877 for no arg - and will try and SvREFCNT_dec it.
879 SvREFCNT(&PL_sv_undef) = 0;
880 SvREADONLY_off(&PL_sv_undef);
882 Safefree(PL_origfilename);
883 Safefree(PL_reg_start_tmp);
885 Safefree(PL_reg_curpm);
886 Safefree(PL_reg_poscache);
887 Safefree(HeKEY_hek(&PL_hv_fetch_ent_mh));
888 Safefree(PL_op_mask);
889 Safefree(PL_psig_ptr);
890 Safefree(PL_psig_name);
891 Safefree(PL_bitcount);
892 Safefree(PL_psig_pend);
894 PL_hints = 0; /* Reset hints. Should hints be per-interpreter ? */
896 DEBUG_P(debprofdump());
897 #ifdef USE_5005THREADS
898 MUTEX_DESTROY(&PL_strtab_mutex);
899 MUTEX_DESTROY(&PL_sv_mutex);
900 MUTEX_DESTROY(&PL_eval_mutex);
901 MUTEX_DESTROY(&PL_cred_mutex);
902 MUTEX_DESTROY(&PL_fdpid_mutex);
903 COND_DESTROY(&PL_eval_cond);
904 #ifdef EMULATE_ATOMIC_REFCOUNTS
905 MUTEX_DESTROY(&PL_svref_mutex);
906 #endif /* EMULATE_ATOMIC_REFCOUNTS */
908 /* As the penultimate thing, free the non-arena SV for thrsv */
909 Safefree(SvPVX(PL_thrsv));
910 Safefree(SvANY(PL_thrsv));
913 #endif /* USE_5005THREADS */
915 #ifdef USE_REENTRANT_API
916 Perl_reentrant_free(aTHX);
921 /* As the absolutely last thing, free the non-arena SV for mess() */
924 /* it could have accumulated taint magic */
925 if (SvTYPE(PL_mess_sv) >= SVt_PVMG) {
928 for (mg = SvMAGIC(PL_mess_sv); mg; mg = moremagic) {
929 moremagic = mg->mg_moremagic;
930 if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global
932 Safefree(mg->mg_ptr);
936 /* we know that type >= SVt_PV */
937 (void)SvOOK_off(PL_mess_sv);
938 Safefree(SvPVX(PL_mess_sv));
939 Safefree(SvANY(PL_mess_sv));
940 Safefree(PL_mess_sv);
943 return STATUS_NATIVE_EXPORT;
947 =for apidoc perl_free
949 Releases a Perl interpreter. See L<perlembed>.
957 #if defined(WIN32) || defined(NETWARE)
958 # if defined(PERL_IMPLICIT_SYS)
960 void *host = nw_internal_host;
962 void *host = w32_internal_host;
966 nw_delete_internal_host(host);
968 win32_delete_internal_host(host);
979 Perl_call_atexit(pTHX_ ATEXIT_t fn, void *ptr)
981 Renew(PL_exitlist, PL_exitlistlen+1, PerlExitListEntry);
982 PL_exitlist[PL_exitlistlen].fn = fn;
983 PL_exitlist[PL_exitlistlen].ptr = ptr;
988 =for apidoc perl_parse
990 Tells a Perl interpreter to parse a Perl script. See L<perlembed>.
996 perl_parse(pTHXx_ XSINIT_t xsinit, int argc, char **argv, char **env)
1001 #ifdef USE_5005THREADS
1005 #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
1008 Perl_croak(aTHX_ "suidperl is no longer needed since the kernel can now execute\n\
1009 setuid perl scripts securely.\n");
1015 /* we copy rather than point to argv
1016 * since perl_clone will copy and perl_destruct
1017 * has no way of knowing if we've made a copy or
1018 * just point to argv
1020 int i = PL_origargc;
1021 New(0, PL_origargv, i+1, char*);
1022 PL_origargv[i] = '\0';
1024 PL_origargv[i] = savepv(argv[i]);
1032 /* Come here if running an undumped a.out. */
1034 PL_origfilename = savepv(argv[0]);
1035 PL_do_undump = FALSE;
1036 cxstack_ix = -1; /* start label stack again */
1038 init_postdump_symbols(argc,argv,env);
1043 PL_curpad = AvARRAY(PL_comppad);
1044 op_free(PL_main_root);
1045 PL_main_root = Nullop;
1047 PL_main_start = Nullop;
1048 SvREFCNT_dec(PL_main_cv);
1049 PL_main_cv = Nullcv;
1052 oldscope = PL_scopestack_ix;
1053 PL_dowarn = G_WARN_OFF;
1055 #ifdef PERL_FLEXIBLE_EXCEPTIONS
1056 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_vparse_body), env, xsinit);
1062 #ifndef PERL_FLEXIBLE_EXCEPTIONS
1063 parse_body(env,xsinit);
1066 call_list(oldscope, PL_checkav);
1073 /* my_exit() was called */
1074 while (PL_scopestack_ix > oldscope)
1077 PL_curstash = PL_defstash;
1079 call_list(oldscope, PL_checkav);
1080 ret = STATUS_NATIVE_EXPORT;
1083 PerlIO_printf(Perl_error_log, "panic: top_env\n");
1091 #ifdef PERL_FLEXIBLE_EXCEPTIONS
1093 S_vparse_body(pTHX_ va_list args)
1095 char **env = va_arg(args, char**);
1096 XSINIT_t xsinit = va_arg(args, XSINIT_t);
1098 return parse_body(env, xsinit);
1103 S_parse_body(pTHX_ char **env, XSINIT_t xsinit)
1105 int argc = PL_origargc;
1106 char **argv = PL_origargv;
1107 char *scriptname = NULL;
1109 VOL bool dosearch = FALSE;
1110 char *validarg = "";
1114 char *cddir = Nullch;
1116 sv_setpvn(PL_linestr,"",0);
1117 sv = newSVpvn("",0); /* first used for -I flags */
1121 for (argc--,argv++; argc > 0; argc--,argv++) {
1122 if (argv[0][0] != '-' || !argv[0][1])
1126 validarg = " PHOOEY ";
1135 win32_argv2utf8(argc-1, argv+1);
1138 #ifndef PERL_STRICT_CR
1162 if ((s = moreswitches(s)))
1167 if( !PL_tainting ) {
1168 PL_taint_warn = TRUE;
1175 PL_taint_warn = FALSE;
1180 #ifdef MACOS_TRADITIONAL
1181 /* ignore -e for Dev:Pseudo argument */
1182 if (argv[1] && !strcmp(argv[1], "Dev:Pseudo"))
1185 if (PL_euid != PL_uid || PL_egid != PL_gid)
1186 Perl_croak(aTHX_ "No -e allowed in setuid scripts");
1188 PL_e_script = newSVpvn("",0);
1189 filter_add(read_e_script, NULL);
1192 sv_catpv(PL_e_script, s);
1194 sv_catpv(PL_e_script, argv[1]);
1198 Perl_croak(aTHX_ "No code specified for -e");
1199 sv_catpv(PL_e_script, "\n");
1202 case 'I': /* -I handled both here and in moreswitches() */
1204 if (!*++s && (s=argv[1]) != Nullch) {
1209 STRLEN len = strlen(s);
1210 p = savepvn(s, len);
1211 incpush(p, TRUE, TRUE);
1212 sv_catpvn(sv, "-I", 2);
1213 sv_catpvn(sv, p, len);
1214 sv_catpvn(sv, " ", 1);
1218 Perl_croak(aTHX_ "No directory specified for -I");
1222 PL_preprocess = TRUE;
1232 PL_preambleav = newAV();
1233 av_push(PL_preambleav, newSVpv("use Config qw(myconfig config_vars)",0));
1235 PL_Sv = newSVpv("print myconfig();",0);
1237 sv_catpv(PL_Sv,"print \"\\nCharacteristics of this PERLSHR image: \\n\",");
1239 sv_catpv(PL_Sv,"print \"\\nCharacteristics of this binary (from libperl): \\n\",");
1241 sv_catpv(PL_Sv,"\" Compile-time options:");
1243 sv_catpv(PL_Sv," DEBUGGING");
1245 # ifdef MULTIPLICITY
1246 sv_catpv(PL_Sv," MULTIPLICITY");
1248 # ifdef USE_5005THREADS
1249 sv_catpv(PL_Sv," USE_5005THREADS");
1251 # ifdef USE_ITHREADS
1252 sv_catpv(PL_Sv," USE_ITHREADS");
1254 # ifdef USE_64_BIT_INT
1255 sv_catpv(PL_Sv," USE_64_BIT_INT");
1257 # ifdef USE_64_BIT_ALL
1258 sv_catpv(PL_Sv," USE_64_BIT_ALL");
1260 # ifdef USE_LONG_DOUBLE
1261 sv_catpv(PL_Sv," USE_LONG_DOUBLE");
1263 # ifdef USE_LARGE_FILES
1264 sv_catpv(PL_Sv," USE_LARGE_FILES");
1267 sv_catpv(PL_Sv," USE_SOCKS");
1269 # ifdef PERL_IMPLICIT_CONTEXT
1270 sv_catpv(PL_Sv," PERL_IMPLICIT_CONTEXT");
1272 # ifdef PERL_IMPLICIT_SYS
1273 sv_catpv(PL_Sv," PERL_IMPLICIT_SYS");
1275 sv_catpv(PL_Sv,"\\n\",");
1277 #if defined(LOCAL_PATCH_COUNT)
1278 if (LOCAL_PATCH_COUNT > 0) {
1280 sv_catpv(PL_Sv,"\" Locally applied patches:\\n\",");
1281 for (i = 1; i <= LOCAL_PATCH_COUNT; i++) {
1282 if (PL_localpatches[i])
1283 Perl_sv_catpvf(aTHX_ PL_Sv,"q\" \t%s\n\",",PL_localpatches[i]);
1287 Perl_sv_catpvf(aTHX_ PL_Sv,"\" Built under %s\\n\"",OSNAME);
1290 Perl_sv_catpvf(aTHX_ PL_Sv,",\" Compiled at %s %s\\n\"",__DATE__,__TIME__);
1292 Perl_sv_catpvf(aTHX_ PL_Sv,",\" Compiled on %s\\n\"",__DATE__);
1295 sv_catpv(PL_Sv, "; \
1297 @env = map { \"$_=\\\"$ENV{$_}\\\"\" } sort grep {/^PERL/} keys %ENV; ");
1300 push @env, \"CYGWIN=\\\"$ENV{CYGWIN}\\\"\";");
1303 print \" \\%ENV:\\n @env\\n\" if @env; \
1304 print \" \\@INC:\\n @INC\\n\";");
1307 PL_Sv = newSVpv("config_vars(qw(",0);
1308 sv_catpv(PL_Sv, ++s);
1309 sv_catpv(PL_Sv, "))");
1312 av_push(PL_preambleav, PL_Sv);
1313 scriptname = BIT_BUCKET; /* don't look for script or read stdin */
1316 PL_doextract = TRUE;
1324 if (!*++s || isSPACE(*s)) {
1328 /* catch use of gnu style long options */
1329 if (strEQ(s, "version")) {
1333 if (strEQ(s, "help")) {
1340 Perl_croak(aTHX_ "Unrecognized switch: -%s (-h will show valid options)",s);
1346 #ifndef SECURE_INTERNAL_GETENV
1349 (s = PerlEnv_getenv("PERL5OPT")))
1354 if (*s == '-' && *(s+1) == 'T') {
1356 PL_taint_warn = FALSE;
1359 char *popt_copy = Nullch;
1372 if (!strchr("DIMUdmtw", *s))
1373 Perl_croak(aTHX_ "Illegal switch in PERL5OPT: -%c", *s);
1377 popt_copy = SvPVX(sv_2mortal(newSVpv(popt,0)));
1378 s = popt_copy + (s - popt);
1379 d = popt_copy + (d - popt);
1386 if( !PL_tainting ) {
1387 PL_taint_warn = TRUE;
1397 if (PL_taint_warn && PL_dowarn != G_WARN_ALL_OFF) {
1398 PL_compiling.cop_warnings = newSVpvn(WARN_TAINTstring, WARNsize);
1402 scriptname = argv[0];
1405 scriptname = BIT_BUCKET; /* don't look for script or read stdin */
1407 else if (scriptname == Nullch) {
1409 if ( PerlLIO_isatty(PerlIO_fileno(PerlIO_stdin())) )
1417 open_script(scriptname,dosearch,sv,&fdscript);
1419 validate_suid(validarg, scriptname,fdscript);
1422 #if defined(SIGCHLD) || defined(SIGCLD)
1425 # define SIGCHLD SIGCLD
1427 Sighandler_t sigstate = rsignal_state(SIGCHLD);
1428 if (sigstate == SIG_IGN) {
1429 if (ckWARN(WARN_SIGNAL))
1430 Perl_warner(aTHX_ packWARN(WARN_SIGNAL),
1431 "Can't ignore signal CHLD, forcing to default");
1432 (void)rsignal(SIGCHLD, (Sighandler_t)SIG_DFL);
1438 #ifdef MACOS_TRADITIONAL
1439 if (PL_doextract || gMacPerl_AlwaysExtract) {
1444 if (cddir && PerlDir_chdir(cddir) < 0)
1445 Perl_croak(aTHX_ "Can't chdir to %s",cddir);
1449 PL_main_cv = PL_compcv = (CV*)NEWSV(1104,0);
1450 sv_upgrade((SV *)PL_compcv, SVt_PVCV);
1451 CvUNIQUE_on(PL_compcv);
1453 PL_comppad = newAV();
1454 av_push(PL_comppad, Nullsv);
1455 PL_curpad = AvARRAY(PL_comppad);
1456 PL_comppad_name = newAV();
1457 PL_comppad_name_fill = 0;
1458 PL_min_intro_pending = 0;
1460 #ifdef USE_5005THREADS
1461 av_store(PL_comppad_name, 0, newSVpvn("@_", 2));
1462 PL_curpad[0] = (SV*)newAV();
1463 SvPADMY_on(PL_curpad[0]); /* XXX Needed? */
1464 CvOWNER(PL_compcv) = 0;
1465 New(666, CvMUTEXP(PL_compcv), 1, perl_mutex);
1466 MUTEX_INIT(CvMUTEXP(PL_compcv));
1467 #endif /* USE_5005THREADS */
1469 comppadlist = newAV();
1470 AvREAL_off(comppadlist);
1471 av_store(comppadlist, 0, (SV*)PL_comppad_name);
1472 av_store(comppadlist, 1, (SV*)PL_comppad);
1473 CvPADLIST(PL_compcv) = comppadlist;
1476 boot_core_UNIVERSAL();
1478 boot_core_xsutils();
1482 (*xsinit)(aTHX); /* in case linked C routines want magical variables */
1484 #if defined(VMS) || defined(WIN32) || defined(DJGPP) || defined(__CYGWIN__) || defined(EPOC)
1490 # ifdef HAS_SOCKS5_INIT
1491 socks5_init(argv[0]);
1497 init_predump_symbols();
1498 /* init_postdump_symbols not currently designed to be called */
1499 /* more than once (ENV isn't cleared first, for example) */
1500 /* But running with -u leaves %ENV & @ARGV undefined! XXX */
1502 init_postdump_symbols(argc,argv,env);
1504 /* PL_wantutf8 is conditionally turned on by
1505 * locale.c:Perl_init_i18nl10n() if the environment
1506 * look like the user wants to use UTF-8. */
1507 if (PL_wantutf8) { /* Requires init_predump_symbols(). */
1511 /* Turn on UTF-8-ness on STDIN, STDOUT, STDERR
1512 * _and_ the default open discipline. */
1513 if (PL_stdingv && (io = GvIO(PL_stdingv)) && (fp = IoIFP(io)))
1514 PerlIO_binmode(aTHX_ fp, IoTYPE(io), 0, ":utf8");
1515 if (PL_defoutgv && (io = GvIO(PL_defoutgv)) && (fp = IoOFP(io)))
1516 PerlIO_binmode(aTHX_ fp, IoTYPE(io), 0, ":utf8");
1517 if (PL_stderrgv && (io = GvIO(PL_stderrgv)) && (fp = IoOFP(io)))
1518 PerlIO_binmode(aTHX_ fp, IoTYPE(io), 0, ":utf8");
1519 if ((sv = GvSV(gv_fetchpv("\017PEN", TRUE, SVt_PV)))) {
1520 sv_setpvn(sv, ":utf8\0:utf8", 11);
1527 /* now parse the script */
1529 SETERRNO(0,SS$_NORMAL);
1531 #ifdef MACOS_TRADITIONAL
1532 if (gMacPerl_SyntaxError = (yyparse() || PL_error_count)) {
1534 Perl_croak(aTHX_ "%s had compilation errors.\n", MacPerl_MPWFileName(PL_origfilename));
1536 Perl_croak(aTHX_ "Execution of %s aborted due to compilation errors.\n",
1537 MacPerl_MPWFileName(PL_origfilename));
1541 if (yyparse() || PL_error_count) {
1543 Perl_croak(aTHX_ "%s had compilation errors.\n", PL_origfilename);
1545 Perl_croak(aTHX_ "Execution of %s aborted due to compilation errors.\n",
1550 CopLINE_set(PL_curcop, 0);
1551 PL_curstash = PL_defstash;
1552 PL_preprocess = FALSE;
1554 SvREFCNT_dec(PL_e_script);
1555 PL_e_script = Nullsv;
1559 Not sure that this is still the right place to do this now that we
1560 no longer use PL_nrs. HVDS 2001/09/09
1562 sv_setsv(get_sv("/", TRUE), PL_rs);
1568 SAVECOPFILE(PL_curcop);
1569 SAVECOPLINE(PL_curcop);
1570 gv_check(PL_defstash);
1577 if ((s=PerlEnv_getenv("PERL_DEBUG_MSTATS")) && atoi(s) >= 2)
1578 dump_mstats("after compilation:");
1587 =for apidoc perl_run
1589 Tells a Perl interpreter to run. See L<perlembed>.
1600 #ifdef USE_5005THREADS
1604 oldscope = PL_scopestack_ix;
1609 #ifdef PERL_FLEXIBLE_EXCEPTIONS
1611 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_vrun_body), oldscope);
1617 cxstack_ix = -1; /* start context stack again */
1619 case 0: /* normal completion */
1620 #ifndef PERL_FLEXIBLE_EXCEPTIONS
1625 case 2: /* my_exit() */
1626 while (PL_scopestack_ix > oldscope)
1629 PL_curstash = PL_defstash;
1630 if (!(PL_exit_flags & PERL_EXIT_DESTRUCT_END) &&
1631 PL_endav && !PL_minus_c)
1632 call_list(oldscope, PL_endav);
1634 if (PerlEnv_getenv("PERL_DEBUG_MSTATS"))
1635 dump_mstats("after execution: ");
1637 ret = STATUS_NATIVE_EXPORT;
1641 POPSTACK_TO(PL_mainstack);
1644 PerlIO_printf(Perl_error_log, "panic: restartop\n");
1654 #ifdef PERL_FLEXIBLE_EXCEPTIONS
1656 S_vrun_body(pTHX_ va_list args)
1658 I32 oldscope = va_arg(args, I32);
1660 return run_body(oldscope);
1666 S_run_body(pTHX_ I32 oldscope)
1668 DEBUG_r(PerlIO_printf(Perl_debug_log, "%s $` $& $' support.\n",
1669 PL_sawampersand ? "Enabling" : "Omitting"));
1671 if (!PL_restartop) {
1672 DEBUG_x(dump_all());
1673 DEBUG(PerlIO_printf(Perl_debug_log, "\nEXECUTING...\n\n"));
1674 DEBUG_S(PerlIO_printf(Perl_debug_log, "main thread is 0x%"UVxf"\n",
1678 #ifdef MACOS_TRADITIONAL
1679 PerlIO_printf(Perl_error_log, "%s%s syntax OK\n",
1680 (gMacPerl_ErrorFormat ? "# " : ""),
1681 MacPerl_MPWFileName(PL_origfilename));
1683 PerlIO_printf(Perl_error_log, "%s syntax OK\n", PL_origfilename);
1687 if (PERLDB_SINGLE && PL_DBsingle)
1688 sv_setiv(PL_DBsingle, 1);
1690 call_list(oldscope, PL_initav);
1696 PL_op = PL_restartop;
1700 else if (PL_main_start) {
1701 CvDEPTH(PL_main_cv) = 1;
1702 PL_op = PL_main_start;
1712 =head1 SV Manipulation Functions
1714 =for apidoc p||get_sv
1716 Returns the SV of the specified Perl scalar. If C<create> is set and the
1717 Perl variable does not exist then it will be created. If C<create> is not
1718 set and the variable does not exist then NULL is returned.
1724 Perl_get_sv(pTHX_ const char *name, I32 create)
1727 #ifdef USE_5005THREADS
1728 if (name[1] == '\0' && !isALPHA(name[0])) {
1729 PADOFFSET tmp = find_threadsv(name);
1730 if (tmp != NOT_IN_PAD)
1731 return THREADSV(tmp);
1733 #endif /* USE_5005THREADS */
1734 gv = gv_fetchpv(name, create, SVt_PV);
1741 =head1 Array Manipulation Functions
1743 =for apidoc p||get_av
1745 Returns the AV of the specified Perl array. If C<create> is set and the
1746 Perl variable does not exist then it will be created. If C<create> is not
1747 set and the variable does not exist then NULL is returned.
1753 Perl_get_av(pTHX_ const char *name, I32 create)
1755 GV* gv = gv_fetchpv(name, create, SVt_PVAV);
1764 =head1 Hash Manipulation Functions
1766 =for apidoc p||get_hv
1768 Returns the HV of the specified Perl hash. If C<create> is set and the
1769 Perl variable does not exist then it will be created. If C<create> is not
1770 set and the variable does not exist then NULL is returned.
1776 Perl_get_hv(pTHX_ const char *name, I32 create)
1778 GV* gv = gv_fetchpv(name, create, SVt_PVHV);
1787 =head1 CV Manipulation Functions
1789 =for apidoc p||get_cv
1791 Returns the CV of the specified Perl subroutine. If C<create> is set and
1792 the Perl subroutine does not exist then it will be declared (which has the
1793 same effect as saying C<sub name;>). If C<create> is not set and the
1794 subroutine does not exist then NULL is returned.
1800 Perl_get_cv(pTHX_ const char *name, I32 create)
1802 GV* gv = gv_fetchpv(name, create, SVt_PVCV);
1803 /* XXX unsafe for threads if eval_owner isn't held */
1804 /* XXX this is probably not what they think they're getting.
1805 * It has the same effect as "sub name;", i.e. just a forward
1807 if (create && !GvCVu(gv))
1808 return newSUB(start_subparse(FALSE, 0),
1809 newSVOP(OP_CONST, 0, newSVpv(name,0)),
1817 /* Be sure to refetch the stack pointer after calling these routines. */
1821 =head1 Callback Functions
1823 =for apidoc p||call_argv
1825 Performs a callback to the specified Perl sub. See L<perlcall>.
1831 Perl_call_argv(pTHX_ const char *sub_name, I32 flags, register char **argv)
1833 /* See G_* flags in cop.h */
1834 /* null terminated arg list */
1841 XPUSHs(sv_2mortal(newSVpv(*argv,0)));
1846 return call_pv(sub_name, flags);
1850 =for apidoc p||call_pv
1852 Performs a callback to the specified Perl sub. See L<perlcall>.
1858 Perl_call_pv(pTHX_ const char *sub_name, I32 flags)
1859 /* name of the subroutine */
1860 /* See G_* flags in cop.h */
1862 return call_sv((SV*)get_cv(sub_name, TRUE), flags);
1866 =for apidoc p||call_method
1868 Performs a callback to the specified Perl method. The blessed object must
1869 be on the stack. See L<perlcall>.
1875 Perl_call_method(pTHX_ const char *methname, I32 flags)
1876 /* name of the subroutine */
1877 /* See G_* flags in cop.h */
1879 return call_sv(sv_2mortal(newSVpv(methname,0)), flags | G_METHOD);
1882 /* May be called with any of a CV, a GV, or an SV containing the name. */
1884 =for apidoc p||call_sv
1886 Performs a callback to the Perl sub whose name is in the SV. See
1893 Perl_call_sv(pTHX_ SV *sv, I32 flags)
1894 /* See G_* flags in cop.h */
1897 LOGOP myop; /* fake syntax tree node */
1900 volatile I32 retval = 0;
1902 bool oldcatch = CATCH_GET;
1907 if (flags & G_DISCARD) {
1912 Zero(&myop, 1, LOGOP);
1913 myop.op_next = Nullop;
1914 if (!(flags & G_NOARGS))
1915 myop.op_flags |= OPf_STACKED;
1916 myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
1917 (flags & G_ARRAY) ? OPf_WANT_LIST :
1922 EXTEND(PL_stack_sp, 1);
1923 *++PL_stack_sp = sv;
1925 oldscope = PL_scopestack_ix;
1927 if (PERLDB_SUB && PL_curstash != PL_debstash
1928 /* Handle first BEGIN of -d. */
1929 && (PL_DBcv || (PL_DBcv = GvCV(PL_DBsub)))
1930 /* Try harder, since this may have been a sighandler, thus
1931 * curstash may be meaningless. */
1932 && (SvTYPE(sv) != SVt_PVCV || CvSTASH((CV*)sv) != PL_debstash)
1933 && !(flags & G_NODEBUG))
1934 PL_op->op_private |= OPpENTERSUB_DB;
1936 if (flags & G_METHOD) {
1937 Zero(&method_op, 1, UNOP);
1938 method_op.op_next = PL_op;
1939 method_op.op_ppaddr = PL_ppaddr[OP_METHOD];
1940 myop.op_ppaddr = PL_ppaddr[OP_ENTERSUB];
1941 PL_op = (OP*)&method_op;
1944 if (!(flags & G_EVAL)) {
1946 call_body((OP*)&myop, FALSE);
1947 retval = PL_stack_sp - (PL_stack_base + oldmark);
1948 CATCH_SET(oldcatch);
1951 myop.op_other = (OP*)&myop;
1953 /* we're trying to emulate pp_entertry() here */
1955 register PERL_CONTEXT *cx;
1956 I32 gimme = GIMME_V;
1961 push_return(Nullop);
1962 PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), PL_stack_sp);
1964 PL_eval_root = PL_op; /* Only needed so that goto works right. */
1966 PL_in_eval = EVAL_INEVAL;
1967 if (flags & G_KEEPERR)
1968 PL_in_eval |= EVAL_KEEPERR;
1974 #ifdef PERL_FLEXIBLE_EXCEPTIONS
1976 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_vcall_body),
1983 #ifndef PERL_FLEXIBLE_EXCEPTIONS
1985 call_body((OP*)&myop, FALSE);
1987 retval = PL_stack_sp - (PL_stack_base + oldmark);
1988 if (!(flags & G_KEEPERR))
1995 /* my_exit() was called */
1996 PL_curstash = PL_defstash;
1999 if (PL_statusvalue && !(PL_exit_flags & PERL_EXIT_EXPECTED))
2000 Perl_croak(aTHX_ "Callback called exit");
2005 PL_op = PL_restartop;
2009 PL_stack_sp = PL_stack_base + oldmark;
2010 if (flags & G_ARRAY)
2014 *++PL_stack_sp = &PL_sv_undef;
2019 if (PL_scopestack_ix > oldscope) {
2023 register PERL_CONTEXT *cx;
2035 if (flags & G_DISCARD) {
2036 PL_stack_sp = PL_stack_base + oldmark;
2045 #ifdef PERL_FLEXIBLE_EXCEPTIONS
2047 S_vcall_body(pTHX_ va_list args)
2049 OP *myop = va_arg(args, OP*);
2050 int is_eval = va_arg(args, int);
2052 call_body(myop, is_eval);
2058 S_call_body(pTHX_ OP *myop, int is_eval)
2060 if (PL_op == myop) {
2062 PL_op = Perl_pp_entereval(aTHX); /* this doesn't do a POPMARK */
2064 PL_op = Perl_pp_entersub(aTHX); /* this does */
2070 /* Eval a string. The G_EVAL flag is always assumed. */
2073 =for apidoc p||eval_sv
2075 Tells Perl to C<eval> the string in the SV.
2081 Perl_eval_sv(pTHX_ SV *sv, I32 flags)
2083 /* See G_* flags in cop.h */
2086 UNOP myop; /* fake syntax tree node */
2087 volatile I32 oldmark = SP - PL_stack_base;
2088 volatile I32 retval = 0;
2094 if (flags & G_DISCARD) {
2101 Zero(PL_op, 1, UNOP);
2102 EXTEND(PL_stack_sp, 1);
2103 *++PL_stack_sp = sv;
2104 oldscope = PL_scopestack_ix;
2106 if (!(flags & G_NOARGS))
2107 myop.op_flags = OPf_STACKED;
2108 myop.op_next = Nullop;
2109 myop.op_type = OP_ENTEREVAL;
2110 myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
2111 (flags & G_ARRAY) ? OPf_WANT_LIST :
2113 if (flags & G_KEEPERR)
2114 myop.op_flags |= OPf_SPECIAL;
2116 #ifdef PERL_FLEXIBLE_EXCEPTIONS
2118 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_vcall_body),
2125 #ifndef PERL_FLEXIBLE_EXCEPTIONS
2127 call_body((OP*)&myop,TRUE);
2129 retval = PL_stack_sp - (PL_stack_base + oldmark);
2130 if (!(flags & G_KEEPERR))
2137 /* my_exit() was called */
2138 PL_curstash = PL_defstash;
2141 if (PL_statusvalue && !(PL_exit_flags & PERL_EXIT_EXPECTED))
2142 Perl_croak(aTHX_ "Callback called exit");
2147 PL_op = PL_restartop;
2151 PL_stack_sp = PL_stack_base + oldmark;
2152 if (flags & G_ARRAY)
2156 *++PL_stack_sp = &PL_sv_undef;
2162 if (flags & G_DISCARD) {
2163 PL_stack_sp = PL_stack_base + oldmark;
2173 =for apidoc p||eval_pv
2175 Tells Perl to C<eval> the given string and return an SV* result.
2181 Perl_eval_pv(pTHX_ const char *p, I32 croak_on_error)
2184 SV* sv = newSVpv(p, 0);
2186 eval_sv(sv, G_SCALAR);
2193 if (croak_on_error && SvTRUE(ERRSV)) {
2195 Perl_croak(aTHX_ SvPVx(ERRSV, n_a));
2201 /* Require a module. */
2204 =head1 Embedding Functions
2206 =for apidoc p||require_pv
2208 Tells Perl to C<require> the file named by the string argument. It is
2209 analogous to the Perl code C<eval "require '$file'">. It's even
2210 implemented that way; consider using Perl_load_module instead.
2215 Perl_require_pv(pTHX_ const char *pv)
2219 PUSHSTACKi(PERLSI_REQUIRE);
2221 sv = sv_newmortal();
2222 sv_setpv(sv, "require '");
2225 eval_sv(sv, G_DISCARD);
2231 Perl_magicname(pTHX_ char *sym, char *name, I32 namlen)
2235 if ((gv = gv_fetchpv(sym,TRUE, SVt_PV)))
2236 sv_magic(GvSV(gv), (SV*)gv, PERL_MAGIC_sv, name, namlen);
2240 S_usage(pTHX_ char *name) /* XXX move this out into a module ? */
2242 /* This message really ought to be max 23 lines.
2243 * Removed -h because the user already knows that option. Others? */
2245 static char *usage_msg[] = {
2246 "-0[octal] specify record separator (\\0, if no argument)",
2247 "-a autosplit mode with -n or -p (splits $_ into @F)",
2248 "-C enable native wide character system interfaces",
2249 "-c check syntax only (runs BEGIN and CHECK blocks)",
2250 "-d[:debugger] run program under debugger",
2251 "-D[number/list] set debugging flags (argument is a bit mask or alphabets)",
2252 "-e 'command' one line of program (several -e's allowed, omit programfile)",
2253 "-F/pattern/ split() pattern for -a switch (//'s are optional)",
2254 "-i[extension] edit <> files in place (makes backup if extension supplied)",
2255 "-Idirectory specify @INC/#include directory (several -I's allowed)",
2256 "-l[octal] enable line ending processing, specifies line terminator",
2257 "-[mM][-]module execute `use/no module...' before executing program",
2258 "-n assume 'while (<>) { ... }' loop around program",
2259 "-p assume loop like -n but print line also, like sed",
2260 "-P run program through C preprocessor before compilation",
2261 "-s enable rudimentary parsing for switches after programfile",
2262 "-S look for programfile using PATH environment variable",
2263 "-T enable tainting checks",
2264 "-t enable tainting warnings",
2265 "-u dump core after parsing program",
2266 "-U allow unsafe operations",
2267 "-v print version, subversion (includes VERY IMPORTANT perl info)",
2268 "-V[:variable] print configuration summary (or a single Config.pm variable)",
2269 "-w enable many useful warnings (RECOMMENDED)",
2270 "-W enable all warnings",
2271 "-X disable all warnings",
2272 "-x[directory] strip off text before #!perl line and perhaps cd to directory",
2276 char **p = usage_msg;
2278 PerlIO_printf(PerlIO_stdout(),
2279 "\nUsage: %s [switches] [--] [programfile] [arguments]",
2282 PerlIO_printf(PerlIO_stdout(), "\n %s", *p++);
2285 /* This routine handles any switches that can be given during run */
2288 Perl_moreswitches(pTHX_ char *s)
2298 rschar = (U32)grok_oct(s, &numlen, &flags, NULL);
2299 SvREFCNT_dec(PL_rs);
2300 if (rschar & ~((U8)~0))
2301 PL_rs = &PL_sv_undef;
2302 else if (!rschar && numlen >= 2)
2303 PL_rs = newSVpvn("", 0);
2305 char ch = (char)rschar;
2306 PL_rs = newSVpvn(&ch, 1);
2311 PL_widesyscalls = TRUE;
2317 while (*s && !isSPACE(*s)) ++s;
2319 PL_splitstr = savepv(PL_splitstr);
2332 /* The following permits -d:Mod to accepts arguments following an =
2333 in the fashion that -MSome::Mod does. */
2334 if (*s == ':' || *s == '=') {
2337 sv = newSVpv("use Devel::", 0);
2339 /* We now allow -d:Module=Foo,Bar */
2340 while(isALNUM(*s) || *s==':') ++s;
2342 sv_catpv(sv, start);
2344 sv_catpvn(sv, start, s-start);
2345 sv_catpv(sv, " split(/,/,q{");
2350 my_setenv("PERL5DB", SvPV(sv, PL_na));
2353 PL_perldb = PERLDB_ALL;
2361 if (isALPHA(s[1])) {
2362 /* if adding extra options, remember to update DEBUG_MASK */
2363 static char debopts[] = "psltocPmfrxuLHXDSTRJvC";
2366 for (s++; *s && (d = strchr(debopts,*s)); s++)
2367 PL_debug |= 1 << (d - debopts);
2370 PL_debug = atoi(s+1);
2371 for (s++; isDIGIT(*s); s++) ;
2374 if (DEBUG_p_TEST_ && ckWARN_d(WARN_DEBUGGING))
2375 Perl_warner(aTHX_ packWARN(WARN_DEBUGGING),
2376 "-Dp not implemented on this platform\n");
2378 PL_debug |= DEBUG_TOP_FLAG;
2379 #else /* !DEBUGGING */
2380 if (ckWARN_d(WARN_DEBUGGING))
2381 Perl_warner(aTHX_ packWARN(WARN_DEBUGGING),
2382 "Recompile perl with -DDEBUGGING to use -D switch\n");
2383 for (s++; isALNUM(*s); s++) ;
2389 usage(PL_origargv[0]);
2393 Safefree(PL_inplace);
2394 #if defined(__CYGWIN__) /* do backup extension automagically */
2395 if (*(s+1) == '\0') {
2396 PL_inplace = savepv(".bak");
2399 #endif /* __CYGWIN__ */
2400 PL_inplace = savepv(s+1);
2402 for (s = PL_inplace; *s && !isSPACE(*s); s++) ;
2405 if (*s == '-') /* Additional switches on #! line. */
2409 case 'I': /* -I handled both here and in parse_body() */
2412 while (*s && isSPACE(*s))
2417 /* ignore trailing spaces (possibly followed by other switches) */
2419 for (e = p; *e && !isSPACE(*e); e++) ;
2423 } while (*p && *p != '-');
2424 e = savepvn(s, e-s);
2425 incpush(e, TRUE, TRUE);
2432 Perl_croak(aTHX_ "No directory specified for -I");
2438 SvREFCNT_dec(PL_ors_sv);
2443 PL_ors_sv = newSVpvn("\n",1);
2444 numlen = 3 + (*s == '0');
2445 *SvPVX(PL_ors_sv) = (char)grok_oct(s, &numlen, &flags, NULL);
2449 if (RsPARA(PL_rs)) {
2450 PL_ors_sv = newSVpvn("\n\n",2);
2453 PL_ors_sv = newSVsv(PL_rs);
2458 forbid_setid("-M"); /* XXX ? */
2461 forbid_setid("-m"); /* XXX ? */
2466 /* -M-foo == 'no foo' */
2467 if (*s == '-') { use = "no "; ++s; }
2468 sv = newSVpv(use,0);
2470 /* We allow -M'Module qw(Foo Bar)' */
2471 while(isALNUM(*s) || *s==':') ++s;
2473 sv_catpv(sv, start);
2474 if (*(start-1) == 'm') {
2476 Perl_croak(aTHX_ "Can't use '%c' after -mname", *s);
2477 sv_catpv( sv, " ()");
2481 Perl_croak(aTHX_ "Module name required with -%c option",
2483 sv_catpvn(sv, start, s-start);
2484 sv_catpv(sv, " split(/,/,q{");
2490 PL_preambleav = newAV();
2491 av_push(PL_preambleav, sv);
2494 Perl_croak(aTHX_ "No space allowed after -%c", *(s-1));
2506 PL_doswitches = TRUE;
2511 Perl_croak(aTHX_ "Too late for \"-t\" option");
2516 Perl_croak(aTHX_ "Too late for \"-T\" option");
2520 #ifdef MACOS_TRADITIONAL
2521 Perl_croak(aTHX_ "Believe me, you don't want to use \"-u\" on a Macintosh");
2523 PL_do_undump = TRUE;
2532 PerlIO_printf(PerlIO_stdout(),
2533 Perl_form(aTHX_ "\nThis is perl, v%"VDf" built for %s",
2534 PL_patchlevel, ARCHNAME));
2536 /* Adjust verbose output as in the perl that ships with the DG/UX OS from EMC */
2537 PerlIO_printf(PerlIO_stdout(),
2538 Perl_form(aTHX_ "\nThis is perl, version %vd\n", PL_patchlevel));
2539 PerlIO_printf(PerlIO_stdout(),
2540 Perl_form(aTHX_ " built under %s at %s %s\n",
2541 OSNAME, __DATE__, __TIME__));
2542 PerlIO_printf(PerlIO_stdout(),
2543 Perl_form(aTHX_ " OS Specific Release: %s\n",
2547 #if defined(LOCAL_PATCH_COUNT)
2548 if (LOCAL_PATCH_COUNT > 0)
2549 PerlIO_printf(PerlIO_stdout(),
2550 "\n(with %d registered patch%s, "
2551 "see perl -V for more detail)",
2552 (int)LOCAL_PATCH_COUNT,
2553 (LOCAL_PATCH_COUNT!=1) ? "es" : "");
2556 PerlIO_printf(PerlIO_stdout(),
2557 "\n\nCopyright 1987-2002, Larry Wall\n");
2558 #ifdef MACOS_TRADITIONAL
2559 PerlIO_printf(PerlIO_stdout(),
2560 "\nMac OS port Copyright 1991-2002, Matthias Neeracher;\n"
2561 "maintained by Chris Nandor\n");
2564 PerlIO_printf(PerlIO_stdout(),
2565 "\nMS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n");
2568 PerlIO_printf(PerlIO_stdout(),
2569 "djgpp v2 port (jpl5003c) by Hirofumi Watanabe, 1996\n"
2570 "djgpp v2 port (perl5004+) by Laszlo Molnar, 1997-1999\n");
2573 PerlIO_printf(PerlIO_stdout(),
2574 "\n\nOS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n"
2575 "Version 5 port Copyright (c) 1994-2002, Andreas Kaiser, Ilya Zakharevich\n");
2578 PerlIO_printf(PerlIO_stdout(),
2579 "atariST series port, ++jrb bammi@cadence.com\n");
2582 PerlIO_printf(PerlIO_stdout(),
2583 "BeOS port Copyright Tom Spindler, 1997-1999\n");
2586 PerlIO_printf(PerlIO_stdout(),
2587 "MPE/iX port Copyright by Mark Klein and Mark Bixby, 1996-2002\n");
2590 PerlIO_printf(PerlIO_stdout(),
2591 "MVS (OS390) port by Mortice Kern Systems, 1997-1999\n");
2594 PerlIO_printf(PerlIO_stdout(),
2595 "Stratus VOS port by Paul.Green@stratus.com, 1997-2002\n");
2598 PerlIO_printf(PerlIO_stdout(),
2599 "VM/ESA port by Neale Ferguson, 1998-1999\n");
2602 PerlIO_printf(PerlIO_stdout(),
2603 "BS2000 (POSIX) port by Start Amadeus GmbH, 1998-1999\n");
2606 PerlIO_printf(PerlIO_stdout(),
2607 "MiNT port by Guido Flohr, 1997-1999\n");
2610 PerlIO_printf(PerlIO_stdout(),
2611 "EPOC port by Olaf Flebbe, 1999-2002\n");
2614 printf("WINCE port by Rainer Keuchel, 2001-2002\n");
2615 printf("Built on " __DATE__ " " __TIME__ "\n\n");
2618 #ifdef BINARY_BUILD_NOTICE
2619 BINARY_BUILD_NOTICE;
2621 PerlIO_printf(PerlIO_stdout(),
2623 Perl may be copied only under the terms of either the Artistic License or the\n\
2624 GNU General Public License, which may be found in the Perl 5 source kit.\n\n\
2625 Complete documentation for Perl, including FAQ lists, should be found on\n\
2626 this system using `man perl' or `perldoc perl'. If you have access to the\n\
2627 Internet, point your browser at http://www.perl.com/, the Perl Home Page.\n\n");
2630 if (! (PL_dowarn & G_WARN_ALL_MASK))
2631 PL_dowarn |= G_WARN_ON;
2635 PL_dowarn = G_WARN_ALL_ON|G_WARN_ON;
2636 if (!specialWARN(PL_compiling.cop_warnings))
2637 SvREFCNT_dec(PL_compiling.cop_warnings);
2638 PL_compiling.cop_warnings = pWARN_ALL ;
2642 PL_dowarn = G_WARN_ALL_OFF;
2643 if (!specialWARN(PL_compiling.cop_warnings))
2644 SvREFCNT_dec(PL_compiling.cop_warnings);
2645 PL_compiling.cop_warnings = pWARN_NONE ;
2650 if (s[1] == '-') /* Additional switches on #! line. */
2655 #if defined(WIN32) || !defined(PERL_STRICT_CR)
2661 #ifdef ALTERNATE_SHEBANG
2662 case 'S': /* OS/2 needs -S on "extproc" line. */
2670 Perl_croak(aTHX_ "Can't emulate -%.1s on #! line",s);
2675 /* compliments of Tom Christiansen */
2677 /* unexec() can be found in the Gnu emacs distribution */
2678 /* Known to work with -DUNEXEC and using unexelf.c from GNU emacs-20.2 */
2681 Perl_my_unexec(pTHX)
2689 prog = newSVpv(BIN_EXP, 0);
2690 sv_catpv(prog, "/perl");
2691 file = newSVpv(PL_origfilename, 0);
2692 sv_catpv(file, ".perldump");
2694 unexec(SvPVX(file), SvPVX(prog), &etext, sbrk(0), 0);
2695 /* unexec prints msg to stderr in case of failure */
2696 PerlProc_exit(status);
2699 # include <lib$routines.h>
2700 lib$signal(SS$_DEBUG); /* ssdef.h #included from vmsish.h */
2702 ABORT(); /* for use with undump */
2707 /* initialize curinterp */
2713 # define PERLVAR(var,type)
2714 # define PERLVARA(var,n,type)
2715 # if defined(PERL_IMPLICIT_CONTEXT)
2716 # if defined(USE_5005THREADS)
2717 # define PERLVARI(var,type,init) PERL_GET_INTERP->var = init;
2718 # define PERLVARIC(var,type,init) PERL_GET_INTERP->var = init;
2719 # else /* !USE_5005THREADS */
2720 # define PERLVARI(var,type,init) aTHX->var = init;
2721 # define PERLVARIC(var,type,init) aTHX->var = init;
2722 # endif /* USE_5005THREADS */
2724 # define PERLVARI(var,type,init) PERL_GET_INTERP->var = init;
2725 # define PERLVARIC(var,type,init) PERL_GET_INTERP->var = init;
2727 # include "intrpvar.h"
2728 # ifndef USE_5005THREADS
2729 # include "thrdvar.h"
2736 # define PERLVAR(var,type)
2737 # define PERLVARA(var,n,type)
2738 # define PERLVARI(var,type,init) PL_##var = init;
2739 # define PERLVARIC(var,type,init) PL_##var = init;
2740 # include "intrpvar.h"
2741 # ifndef USE_5005THREADS
2742 # include "thrdvar.h"
2753 S_init_main_stash(pTHX)
2757 PL_curstash = PL_defstash = newHV();
2758 PL_curstname = newSVpvn("main",4);
2759 gv = gv_fetchpv("main::",TRUE, SVt_PVHV);
2760 SvREFCNT_dec(GvHV(gv));
2761 GvHV(gv) = (HV*)SvREFCNT_inc(PL_defstash);
2763 HvNAME(PL_defstash) = savepv("main");
2764 PL_incgv = gv_HVadd(gv_AVadd(gv_fetchpv("INC",TRUE, SVt_PVAV)));
2765 GvMULTI_on(PL_incgv);
2766 PL_hintgv = gv_fetchpv("\010",TRUE, SVt_PV); /* ^H */
2767 GvMULTI_on(PL_hintgv);
2768 PL_defgv = gv_fetchpv("_",TRUE, SVt_PVAV);
2769 PL_errgv = gv_HVadd(gv_fetchpv("@", TRUE, SVt_PV));
2770 GvMULTI_on(PL_errgv);
2771 PL_replgv = gv_fetchpv("\022", TRUE, SVt_PV); /* ^R */
2772 GvMULTI_on(PL_replgv);
2773 (void)Perl_form(aTHX_ "%240s",""); /* Preallocate temp - for immediate signals. */
2774 sv_grow(ERRSV, 240); /* Preallocate - for immediate signals. */
2775 sv_setpvn(ERRSV, "", 0);
2776 PL_curstash = PL_defstash;
2777 CopSTASH_set(&PL_compiling, PL_defstash);
2778 PL_debstash = GvHV(gv_fetchpv("DB::", GV_ADDMULTI, SVt_PVHV));
2779 PL_globalstash = GvHV(gv_fetchpv("CORE::GLOBAL::", GV_ADDMULTI, SVt_PVHV));
2780 PL_nullstash = GvHV(gv_fetchpv("<none>::", GV_ADDMULTI, SVt_PVHV));
2781 /* We must init $/ before switches are processed. */
2782 sv_setpvn(get_sv("/", TRUE), "\n", 1);
2786 S_open_script(pTHX_ char *scriptname, bool dosearch, SV *sv, int *fdscript)
2790 char *cpp_discard_flag;
2796 PL_origfilename = savepv("-e");
2799 /* if find_script() returns, it returns a malloc()-ed value */
2800 PL_origfilename = scriptname = find_script(scriptname, dosearch, NULL, 1);
2802 if (strnEQ(scriptname, "/dev/fd/", 8) && isDIGIT(scriptname[8]) ) {
2803 char *s = scriptname + 8;
2804 *fdscript = atoi(s);
2808 scriptname = savepv(s + 1);
2809 Safefree(PL_origfilename);
2810 PL_origfilename = scriptname;
2815 CopFILE_free(PL_curcop);
2816 CopFILE_set(PL_curcop, PL_origfilename);
2817 if (strEQ(PL_origfilename,"-"))
2819 if (*fdscript >= 0) {
2820 PL_rsfp = PerlIO_fdopen(*fdscript,PERL_SCRIPT_MODE);
2821 # if defined(HAS_FCNTL) && defined(F_SETFD)
2823 /* ensure close-on-exec */
2824 fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,1);
2827 else if (PL_preprocess) {
2828 char *cpp_cfg = CPPSTDIN;
2829 SV *cpp = newSVpvn("",0);
2830 SV *cmd = NEWSV(0,0);
2832 if (strEQ(cpp_cfg, "cppstdin"))
2833 Perl_sv_catpvf(aTHX_ cpp, "%s/", BIN_EXP);
2834 sv_catpv(cpp, cpp_cfg);
2837 sv_catpvn(sv, "-I", 2);
2838 sv_catpv(sv,PRIVLIB_EXP);
2841 DEBUG_P(PerlIO_printf(Perl_debug_log,
2842 "PL_preprocess: scriptname=\"%s\", cpp=\"%s\", sv=\"%s\", CPPMINUS=\"%s\"\n",
2843 scriptname, SvPVX (cpp), SvPVX (sv), CPPMINUS));
2845 # if defined(MSDOS) || defined(WIN32) || defined(VMS)
2852 cpp_discard_flag = "";
2854 cpp_discard_flag = "-C";
2858 perl = os2_execname(aTHX);
2860 perl = PL_origargv[0];
2864 /* This strips off Perl comments which might interfere with
2865 the C pre-processor, including #!. #line directives are
2866 deliberately stripped to avoid confusion with Perl's version
2867 of #line. FWP played some golf with it so it will fit
2868 into VMS's 255 character buffer.
2871 code = "(1../^#!.*perl/i)|/^\\s*#(?!\\s*((ifn?|un)def|(el|end)?if|define|include|else|error|pragma)\\b)/||!($|=1)||print";
2873 code = "/^\\s*#(?!\\s*((ifn?|un)def|(el|end)?if|define|include|else|error|pragma)\\b)/||!($|=1)||print";
2875 Perl_sv_setpvf(aTHX_ cmd, "\
2876 %s -ne%s%s%s %s | %"SVf" %s %"SVf" %s",
2877 perl, quote, code, quote, scriptname, cpp,
2878 cpp_discard_flag, sv, CPPMINUS);
2880 PL_doextract = FALSE;
2881 # ifdef IAMSUID /* actually, this is caught earlier */
2882 if (PL_euid != PL_uid && !PL_euid) { /* if running suidperl */
2884 (void)seteuid(PL_uid); /* musn't stay setuid root */
2886 # ifdef HAS_SETREUID
2887 (void)setreuid((Uid_t)-1, PL_uid);
2889 # ifdef HAS_SETRESUID
2890 (void)setresuid((Uid_t)-1, PL_uid, (Uid_t)-1);
2892 PerlProc_setuid(PL_uid);
2896 if (PerlProc_geteuid() != PL_uid)
2897 Perl_croak(aTHX_ "Can't do seteuid!\n");
2899 # endif /* IAMSUID */
2901 DEBUG_P(PerlIO_printf(Perl_debug_log,
2902 "PL_preprocess: cmd=\"%s\"\n",
2905 PL_rsfp = PerlProc_popen(SvPVX(cmd), "r");
2909 else if (!*scriptname) {
2910 forbid_setid("program input from stdin");
2911 PL_rsfp = PerlIO_stdin();
2914 PL_rsfp = PerlIO_open(scriptname,PERL_SCRIPT_MODE);
2915 # if defined(HAS_FCNTL) && defined(F_SETFD)
2917 /* ensure close-on-exec */
2918 fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,1);
2923 # ifndef IAMSUID /* in case script is not readable before setuid */
2925 PerlLIO_stat(CopFILE(PL_curcop),&PL_statbuf) >= 0 &&
2926 PL_statbuf.st_mode & (S_ISUID|S_ISGID))
2929 PerlProc_execv(Perl_form(aTHX_ "%s/sperl"PERL_FS_VER_FMT,
2930 BIN_EXP, (int)PERL_REVISION,
2932 (int)PERL_SUBVERSION), PL_origargv);
2933 Perl_croak(aTHX_ "Can't do setuid\n");
2939 Perl_croak(aTHX_ "Can't open perl script: %s\n",
2942 Perl_croak(aTHX_ "Can't open perl script \"%s\": %s\n",
2943 CopFILE(PL_curcop), Strerror(errno));
2949 * I_SYSSTATVFS HAS_FSTATVFS
2951 * I_STATFS HAS_FSTATFS HAS_GETFSSTAT
2952 * I_MNTENT HAS_GETMNTENT HAS_HASMNTOPT
2953 * here so that metaconfig picks them up. */
2957 S_fd_on_nosuid_fs(pTHX_ int fd)
2959 int check_okay = 0; /* able to do all the required sys/libcalls */
2960 int on_nosuid = 0; /* the fd is on a nosuid fs */
2962 * Preferred order: fstatvfs(), fstatfs(), ustat()+getmnt(), getmntent().
2963 * fstatvfs() is UNIX98.
2964 * fstatfs() is 4.3 BSD.
2965 * ustat()+getmnt() is pre-4.3 BSD.
2966 * getmntent() is O(number-of-mounted-filesystems) and can hang on
2967 * an irrelevant filesystem while trying to reach the right one.
2970 #undef FD_ON_NOSUID_CHECK_OKAY /* found the syscalls to do the check? */
2972 # if !defined(FD_ON_NOSUID_CHECK_OKAY) && \
2973 defined(HAS_FSTATVFS)
2974 # define FD_ON_NOSUID_CHECK_OKAY
2975 struct statvfs stfs;
2977 check_okay = fstatvfs(fd, &stfs) == 0;
2978 on_nosuid = check_okay && (stfs.f_flag & ST_NOSUID);
2979 # endif /* fstatvfs */
2981 # if !defined(FD_ON_NOSUID_CHECK_OKAY) && \
2982 defined(PERL_MOUNT_NOSUID) && \
2983 defined(HAS_FSTATFS) && \
2984 defined(HAS_STRUCT_STATFS) && \
2985 defined(HAS_STRUCT_STATFS_F_FLAGS)
2986 # define FD_ON_NOSUID_CHECK_OKAY
2989 check_okay = fstatfs(fd, &stfs) == 0;
2990 on_nosuid = check_okay && (stfs.f_flags & PERL_MOUNT_NOSUID);
2991 # endif /* fstatfs */
2993 # if !defined(FD_ON_NOSUID_CHECK_OKAY) && \
2994 defined(PERL_MOUNT_NOSUID) && \
2995 defined(HAS_FSTAT) && \
2996 defined(HAS_USTAT) && \
2997 defined(HAS_GETMNT) && \
2998 defined(HAS_STRUCT_FS_DATA) && \
3000 # define FD_ON_NOSUID_CHECK_OKAY
3003 if (fstat(fd, &fdst) == 0) {
3005 if (ustat(fdst.st_dev, &us) == 0) {
3007 /* NOSTAT_ONE here because we're not examining fields which
3008 * vary between that case and STAT_ONE. */
3009 if (getmnt((int*)0, &fsd, (int)0, NOSTAT_ONE, us.f_fname) == 0) {
3010 size_t cmplen = sizeof(us.f_fname);
3011 if (sizeof(fsd.fd_req.path) < cmplen)
3012 cmplen = sizeof(fsd.fd_req.path);
3013 if (strnEQ(fsd.fd_req.path, us.f_fname, cmplen) &&
3014 fdst.st_dev == fsd.fd_req.dev) {
3016 on_nosuid = fsd.fd_req.flags & PERL_MOUNT_NOSUID;
3022 # endif /* fstat+ustat+getmnt */
3024 # if !defined(FD_ON_NOSUID_CHECK_OKAY) && \
3025 defined(HAS_GETMNTENT) && \
3026 defined(HAS_HASMNTOPT) && \
3027 defined(MNTOPT_NOSUID)
3028 # define FD_ON_NOSUID_CHECK_OKAY
3029 FILE *mtab = fopen("/etc/mtab", "r");
3030 struct mntent *entry;
3033 if (mtab && (fstat(fd, &stb) == 0)) {
3034 while (entry = getmntent(mtab)) {
3035 if (stat(entry->mnt_dir, &fsb) == 0
3036 && fsb.st_dev == stb.st_dev)
3038 /* found the filesystem */
3040 if (hasmntopt(entry, MNTOPT_NOSUID))
3043 } /* A single fs may well fail its stat(). */
3048 # endif /* getmntent+hasmntopt */
3051 Perl_croak(aTHX_ "Can't check filesystem of script \"%s\" for nosuid", PL_origfilename);
3054 #endif /* IAMSUID */
3057 S_validate_suid(pTHX_ char *validarg, char *scriptname, int fdscript)
3063 /* do we need to emulate setuid on scripts? */
3065 /* This code is for those BSD systems that have setuid #! scripts disabled
3066 * in the kernel because of a security problem. Merely defining DOSUID
3067 * in perl will not fix that problem, but if you have disabled setuid
3068 * scripts in the kernel, this will attempt to emulate setuid and setgid
3069 * on scripts that have those now-otherwise-useless bits set. The setuid
3070 * root version must be called suidperl or sperlN.NNN. If regular perl
3071 * discovers that it has opened a setuid script, it calls suidperl with
3072 * the same argv that it had. If suidperl finds that the script it has
3073 * just opened is NOT setuid root, it sets the effective uid back to the
3074 * uid. We don't just make perl setuid root because that loses the
3075 * effective uid we had before invoking perl, if it was different from the
3078 * DOSUID must be defined in both perl and suidperl, and IAMSUID must
3079 * be defined in suidperl only. suidperl must be setuid root. The
3080 * Configure script will set this up for you if you want it.
3086 if (PerlLIO_fstat(PerlIO_fileno(PL_rsfp),&PL_statbuf) < 0) /* normal stat is insecure */
3087 Perl_croak(aTHX_ "Can't stat script \"%s\"",PL_origfilename);
3088 if (fdscript < 0 && PL_statbuf.st_mode & (S_ISUID|S_ISGID)) {
3093 #ifndef HAS_SETREUID
3094 /* On this access check to make sure the directories are readable,
3095 * there is actually a small window that the user could use to make
3096 * filename point to an accessible directory. So there is a faint
3097 * chance that someone could execute a setuid script down in a
3098 * non-accessible directory. I don't know what to do about that.
3099 * But I don't think it's too important. The manual lies when
3100 * it says access() is useful in setuid programs.
3102 if (PerlLIO_access(CopFILE(PL_curcop),1)) /*double check*/
3103 Perl_croak(aTHX_ "Permission denied");
3105 /* If we can swap euid and uid, then we can determine access rights
3106 * with a simple stat of the file, and then compare device and
3107 * inode to make sure we did stat() on the same file we opened.
3108 * Then we just have to make sure he or she can execute it.
3115 setreuid(PL_euid,PL_uid) < 0
3118 setresuid(PL_euid,PL_uid,(Uid_t)-1) < 0
3121 || PerlProc_getuid() != PL_euid || PerlProc_geteuid() != PL_uid)
3122 Perl_croak(aTHX_ "Can't swap uid and euid"); /* really paranoid */
3123 if (PerlLIO_stat(CopFILE(PL_curcop),&tmpstatbuf) < 0)
3124 Perl_croak(aTHX_ "Permission denied"); /* testing full pathname here */
3125 #if defined(IAMSUID) && !defined(NO_NOSUID_CHECK)
3126 if (fd_on_nosuid_fs(PerlIO_fileno(PL_rsfp)))
3127 Perl_croak(aTHX_ "Permission denied");
3129 if (tmpstatbuf.st_dev != PL_statbuf.st_dev ||
3130 tmpstatbuf.st_ino != PL_statbuf.st_ino) {
3131 (void)PerlIO_close(PL_rsfp);
3132 Perl_croak(aTHX_ "Permission denied\n");
3136 setreuid(PL_uid,PL_euid) < 0
3138 # if defined(HAS_SETRESUID)
3139 setresuid(PL_uid,PL_euid,(Uid_t)-1) < 0
3142 || PerlProc_getuid() != PL_uid || PerlProc_geteuid() != PL_euid)
3143 Perl_croak(aTHX_ "Can't reswap uid and euid");
3144 if (!cando(S_IXUSR,FALSE,&PL_statbuf)) /* can real uid exec? */
3145 Perl_croak(aTHX_ "Permission denied\n");
3147 #endif /* HAS_SETREUID */
3148 #endif /* IAMSUID */
3150 if (!S_ISREG(PL_statbuf.st_mode))
3151 Perl_croak(aTHX_ "Permission denied");
3152 if (PL_statbuf.st_mode & S_IWOTH)
3153 Perl_croak(aTHX_ "Setuid/gid script is writable by world");
3154 PL_doswitches = FALSE; /* -s is insecure in suid */
3155 CopLINE_inc(PL_curcop);
3156 if (sv_gets(PL_linestr, PL_rsfp, 0) == Nullch ||
3157 strnNE(SvPV(PL_linestr,n_a),"#!",2) ) /* required even on Sys V */
3158 Perl_croak(aTHX_ "No #! line");
3159 s = SvPV(PL_linestr,n_a)+2;
3161 while (!isSPACE(*s)) s++;
3162 for (s2 = s; (s2 > SvPV(PL_linestr,n_a)+2 &&
3163 (isDIGIT(s2[-1]) || strchr("._-", s2[-1]))); s2--) ;
3164 if (strnNE(s2-4,"perl",4) && strnNE(s-9,"perl",4)) /* sanity check */
3165 Perl_croak(aTHX_ "Not a perl script");
3166 while (*s == ' ' || *s == '\t') s++;
3168 * #! arg must be what we saw above. They can invoke it by
3169 * mentioning suidperl explicitly, but they may not add any strange
3170 * arguments beyond what #! says if they do invoke suidperl that way.
3172 len = strlen(validarg);
3173 if (strEQ(validarg," PHOOEY ") ||
3174 strnNE(s,validarg,len) || !isSPACE(s[len]))
3175 Perl_croak(aTHX_ "Args must match #! line");
3178 if (PL_euid != PL_uid && (PL_statbuf.st_mode & S_ISUID) &&
3179 PL_euid == PL_statbuf.st_uid)
3181 Perl_croak(aTHX_ "YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
3182 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
3183 #endif /* IAMSUID */
3185 if (PL_euid) { /* oops, we're not the setuid root perl */
3186 (void)PerlIO_close(PL_rsfp);
3189 PerlProc_execv(Perl_form(aTHX_ "%s/sperl"PERL_FS_VER_FMT, BIN_EXP,
3190 (int)PERL_REVISION, (int)PERL_VERSION,
3191 (int)PERL_SUBVERSION), PL_origargv);
3193 Perl_croak(aTHX_ "Can't do setuid\n");
3196 if (PL_statbuf.st_mode & S_ISGID && PL_statbuf.st_gid != PL_egid) {
3198 (void)setegid(PL_statbuf.st_gid);
3201 (void)setregid((Gid_t)-1,PL_statbuf.st_gid);
3203 #ifdef HAS_SETRESGID
3204 (void)setresgid((Gid_t)-1,PL_statbuf.st_gid,(Gid_t)-1);
3206 PerlProc_setgid(PL_statbuf.st_gid);
3210 if (PerlProc_getegid() != PL_statbuf.st_gid)
3211 Perl_croak(aTHX_ "Can't do setegid!\n");
3213 if (PL_statbuf.st_mode & S_ISUID) {
3214 if (PL_statbuf.st_uid != PL_euid)
3216 (void)seteuid(PL_statbuf.st_uid); /* all that for this */
3219 (void)setreuid((Uid_t)-1,PL_statbuf.st_uid);
3221 #ifdef HAS_SETRESUID
3222 (void)setresuid((Uid_t)-1,PL_statbuf.st_uid,(Uid_t)-1);
3224 PerlProc_setuid(PL_statbuf.st_uid);
3228 if (PerlProc_geteuid() != PL_statbuf.st_uid)
3229 Perl_croak(aTHX_ "Can't do seteuid!\n");
3231 else if (PL_uid) { /* oops, mustn't run as root */
3233 (void)seteuid((Uid_t)PL_uid);
3236 (void)setreuid((Uid_t)-1,(Uid_t)PL_uid);
3238 #ifdef HAS_SETRESUID
3239 (void)setresuid((Uid_t)-1,(Uid_t)PL_uid,(Uid_t)-1);
3241 PerlProc_setuid((Uid_t)PL_uid);
3245 if (PerlProc_geteuid() != PL_uid)
3246 Perl_croak(aTHX_ "Can't do seteuid!\n");
3249 if (!cando(S_IXUSR,TRUE,&PL_statbuf))
3250 Perl_croak(aTHX_ "Permission denied\n"); /* they can't do this */
3253 else if (PL_preprocess)
3254 Perl_croak(aTHX_ "-P not allowed for setuid/setgid script\n");
3255 else if (fdscript >= 0)
3256 Perl_croak(aTHX_ "fd script not allowed in suidperl\n");
3258 Perl_croak(aTHX_ "Script is not setuid/setgid in suidperl\n");
3260 /* We absolutely must clear out any saved ids here, so we */
3261 /* exec the real perl, substituting fd script for scriptname. */
3262 /* (We pass script name as "subdir" of fd, which perl will grok.) */
3263 PerlIO_rewind(PL_rsfp);
3264 PerlLIO_lseek(PerlIO_fileno(PL_rsfp),(Off_t)0,0); /* just in case rewind didn't */
3265 for (which = 1; PL_origargv[which] && PL_origargv[which] != scriptname; which++) ;
3266 if (!PL_origargv[which])
3267 Perl_croak(aTHX_ "Permission denied");
3268 PL_origargv[which] = savepv(Perl_form(aTHX_ "/dev/fd/%d/%s",
3269 PerlIO_fileno(PL_rsfp), PL_origargv[which]));
3270 #if defined(HAS_FCNTL) && defined(F_SETFD)
3271 fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,0); /* ensure no close-on-exec */
3273 PerlProc_execv(Perl_form(aTHX_ "%s/perl"PERL_FS_VER_FMT, BIN_EXP,
3274 (int)PERL_REVISION, (int)PERL_VERSION,
3275 (int)PERL_SUBVERSION), PL_origargv);/* try again */
3276 Perl_croak(aTHX_ "Can't do setuid\n");
3277 #endif /* IAMSUID */
3279 if (PL_euid != PL_uid || PL_egid != PL_gid) { /* (suidperl doesn't exist, in fact) */
3280 #ifndef SETUID_SCRIPTS_ARE_SECURE_NOW
3281 PerlLIO_fstat(PerlIO_fileno(PL_rsfp),&PL_statbuf); /* may be either wrapped or real suid */
3282 if ((PL_euid != PL_uid && PL_euid == PL_statbuf.st_uid && PL_statbuf.st_mode & S_ISUID)
3284 (PL_egid != PL_gid && PL_egid == PL_statbuf.st_gid && PL_statbuf.st_mode & S_ISGID)
3287 Perl_croak(aTHX_ "YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
3288 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
3289 #endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
3290 /* not set-id, must be wrapped */
3296 S_find_beginning(pTHX)
3298 register char *s, *s2;
3299 #ifdef MACOS_TRADITIONAL
3303 /* skip forward in input to the real script? */
3306 #ifdef MACOS_TRADITIONAL
3307 /* Since the Mac OS does not honor #! arguments for us, we do it ourselves */
3309 while (PL_doextract || gMacPerl_AlwaysExtract) {
3310 if ((s = sv_gets(PL_linestr, PL_rsfp, 0)) == Nullch) {
3311 if (!gMacPerl_AlwaysExtract)
3312 Perl_croak(aTHX_ "No Perl script found in input\n");
3314 if (PL_doextract) /* require explicit override ? */
3315 if (!OverrideExtract(PL_origfilename))
3316 Perl_croak(aTHX_ "User aborted script\n");
3318 PL_doextract = FALSE;
3320 /* Pater peccavi, file does not have #! */
3321 PerlIO_rewind(PL_rsfp);
3326 while (PL_doextract) {
3327 if ((s = sv_gets(PL_linestr, PL_rsfp, 0)) == Nullch)
3328 Perl_croak(aTHX_ "No Perl script found in input\n");
3331 if (*s == '#' && s[1] == '!' && ((s = instr(s,"perl")) || (s = instr(s2,"PERL")))) {
3332 PerlIO_ungetc(PL_rsfp, '\n'); /* to keep line count right */
3333 PL_doextract = FALSE;
3334 while (*s && !(isSPACE (*s) || *s == '#')) s++;
3336 while (*s == ' ' || *s == '\t') s++;
3338 while (isDIGIT(s2[-1]) || strchr("-._", s2[-1])) s2--;
3339 if (strnEQ(s2-4,"perl",4))
3341 while ((s = moreswitches(s)))
3344 #ifdef MACOS_TRADITIONAL
3345 /* We are always searching for the #!perl line in MacPerl,
3346 * so if we find it, still keep the line count correct
3347 * by counting lines we already skipped over
3349 for (; maclines > 0 ; maclines--)
3350 PerlIO_ungetc(PL_rsfp, '\n');
3354 /* gMacPerl_AlwaysExtract is false in MPW tool */
3355 } else if (gMacPerl_AlwaysExtract) {
3366 PL_uid = PerlProc_getuid();
3367 PL_euid = PerlProc_geteuid();
3368 PL_gid = PerlProc_getgid();
3369 PL_egid = PerlProc_getegid();
3371 PL_uid |= PL_gid << 16;
3372 PL_euid |= PL_egid << 16;
3374 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
3378 S_forbid_setid(pTHX_ char *s)
3380 if (PL_euid != PL_uid)
3381 Perl_croak(aTHX_ "No %s allowed while running setuid", s);
3382 if (PL_egid != PL_gid)
3383 Perl_croak(aTHX_ "No %s allowed while running setgid", s);
3387 Perl_init_debugger(pTHX)
3389 HV *ostash = PL_curstash;
3391 PL_curstash = PL_debstash;
3392 PL_dbargs = GvAV(gv_AVadd((gv_fetchpv("args", GV_ADDMULTI, SVt_PVAV))));
3393 AvREAL_off(PL_dbargs);
3394 PL_DBgv = gv_fetchpv("DB", GV_ADDMULTI, SVt_PVGV);
3395 PL_DBline = gv_fetchpv("dbline", GV_ADDMULTI, SVt_PVAV);
3396 PL_DBsub = gv_HVadd(gv_fetchpv("sub", GV_ADDMULTI, SVt_PVHV));
3397 sv_upgrade(GvSV(PL_DBsub), SVt_IV); /* IVX accessed if PERLDB_SUB_NN */
3398 PL_DBsingle = GvSV((gv_fetchpv("single", GV_ADDMULTI, SVt_PV)));
3399 sv_setiv(PL_DBsingle, 0);
3400 PL_DBtrace = GvSV((gv_fetchpv("trace", GV_ADDMULTI, SVt_PV)));
3401 sv_setiv(PL_DBtrace, 0);
3402 PL_DBsignal = GvSV((gv_fetchpv("signal", GV_ADDMULTI, SVt_PV)));
3403 sv_setiv(PL_DBsignal, 0);
3404 PL_curstash = ostash;
3407 #ifndef STRESS_REALLOC
3408 #define REASONABLE(size) (size)
3410 #define REASONABLE(size) (1) /* unreasonable */
3414 Perl_init_stacks(pTHX)
3416 /* start with 128-item stack and 8K cxstack */
3417 PL_curstackinfo = new_stackinfo(REASONABLE(128),
3418 REASONABLE(8192/sizeof(PERL_CONTEXT) - 1));
3419 PL_curstackinfo->si_type = PERLSI_MAIN;
3420 PL_curstack = PL_curstackinfo->si_stack;
3421 PL_mainstack = PL_curstack; /* remember in case we switch stacks */
3423 PL_stack_base = AvARRAY(PL_curstack);
3424 PL_stack_sp = PL_stack_base;
3425 PL_stack_max = PL_stack_base + AvMAX(PL_curstack);
3427 New(50,PL_tmps_stack,REASONABLE(128),SV*);
3430 PL_tmps_max = REASONABLE(128);
3432 New(54,PL_markstack,REASONABLE(32),I32);
3433 PL_markstack_ptr = PL_markstack;
3434 PL_markstack_max = PL_markstack + REASONABLE(32);
3438 New(54,PL_scopestack,REASONABLE(32),I32);
3439 PL_scopestack_ix = 0;
3440 PL_scopestack_max = REASONABLE(32);
3442 New(54,PL_savestack,REASONABLE(128),ANY);
3443 PL_savestack_ix = 0;
3444 PL_savestack_max = REASONABLE(128);
3446 New(54,PL_retstack,REASONABLE(16),OP*);
3448 PL_retstack_max = REASONABLE(16);
3456 while (PL_curstackinfo->si_next)
3457 PL_curstackinfo = PL_curstackinfo->si_next;
3458 while (PL_curstackinfo) {
3459 PERL_SI *p = PL_curstackinfo->si_prev;
3460 /* curstackinfo->si_stack got nuked by sv_free_arenas() */
3461 Safefree(PL_curstackinfo->si_cxstack);
3462 Safefree(PL_curstackinfo);
3463 PL_curstackinfo = p;
3465 Safefree(PL_tmps_stack);
3466 Safefree(PL_markstack);
3467 Safefree(PL_scopestack);
3468 Safefree(PL_savestack);
3469 Safefree(PL_retstack);
3478 lex_start(PL_linestr);
3480 PL_subname = newSVpvn("main",4);
3484 S_init_predump_symbols(pTHX)
3489 sv_setpvn(get_sv("\"", TRUE), " ", 1);
3490 PL_stdingv = gv_fetchpv("STDIN",TRUE, SVt_PVIO);
3491 GvMULTI_on(PL_stdingv);
3492 io = GvIOp(PL_stdingv);
3493 IoTYPE(io) = IoTYPE_RDONLY;
3494 IoIFP(io) = PerlIO_stdin();
3495 tmpgv = gv_fetchpv("stdin",TRUE, SVt_PV);
3497 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io);
3499 tmpgv = gv_fetchpv("STDOUT",TRUE, SVt_PVIO);
3502 IoTYPE(io) = IoTYPE_WRONLY;
3503 IoOFP(io) = IoIFP(io) = PerlIO_stdout();
3505 tmpgv = gv_fetchpv("stdout",TRUE, SVt_PV);
3507 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io);
3509 PL_stderrgv = gv_fetchpv("STDERR",TRUE, SVt_PVIO);
3510 GvMULTI_on(PL_stderrgv);
3511 io = GvIOp(PL_stderrgv);
3512 IoTYPE(io) = IoTYPE_WRONLY;
3513 IoOFP(io) = IoIFP(io) = PerlIO_stderr();
3514 tmpgv = gv_fetchpv("stderr",TRUE, SVt_PV);
3516 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io);
3518 PL_statname = NEWSV(66,0); /* last filename we did stat on */
3521 Safefree(PL_osname);
3522 PL_osname = savepv(OSNAME);
3526 Perl_init_argv_symbols(pTHX_ register int argc, register char **argv)
3529 argc--,argv++; /* skip name of script */
3530 if (PL_doswitches) {
3531 for (; argc > 0 && **argv == '-'; argc--,argv++) {
3534 if (argv[0][1] == '-' && !argv[0][2]) {
3538 if ((s = strchr(argv[0], '='))) {
3540 sv_setpv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),s);
3543 sv_setiv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),1);
3546 if ((PL_argvgv = gv_fetchpv("ARGV",TRUE, SVt_PVAV))) {
3547 GvMULTI_on(PL_argvgv);
3548 (void)gv_AVadd(PL_argvgv);
3549 av_clear(GvAVn(PL_argvgv));
3550 for (; argc > 0; argc--,argv++) {
3551 SV *sv = newSVpv(argv[0],0);
3552 av_push(GvAVn(PL_argvgv),sv);
3553 if (PL_widesyscalls)
3554 (void)sv_utf8_decode(sv);
3559 #ifdef HAS_PROCSELFEXE
3560 /* This is a function so that we don't hold on to MAXPATHLEN
3561 bytes of stack longer than necessary
3564 S_procself_val(pTHX_ SV *sv, char *arg0)
3566 char buf[MAXPATHLEN];
3567 int len = readlink(PROCSELFEXE_PATH, buf, sizeof(buf) - 1);
3569 /* On Playstation2 Linux V1.0 (kernel 2.2.1) readlink(/proc/self/exe)
3570 includes a spurious NUL which will cause $^X to fail in system
3571 or backticks (this will prevent extensions from being built and
3572 many tests from working). readlink is not meant to add a NUL.
3573 Normal readlink works fine.
3575 if (len > 0 && buf[len-1] == '\0') {
3579 /* FreeBSD's implementation is acknowledged to be imperfect, sometimes
3580 returning the text "unknown" from the readlink rather than the path
3581 to the executable (or returning an error from the readlink). Any valid
3582 path has a '/' in it somewhere, so use that to validate the result.
3583 See http://www.freebsd.org/cgi/query-pr.cgi?pr=35703
3585 if (len > 0 && memchr(buf, '/', len)) {
3586 sv_setpvn(sv,buf,len);
3592 #endif /* HAS_PROCSELFEXE */
3595 S_init_postdump_symbols(pTHX_ register int argc, register char **argv, register char **env)
3601 PL_toptarget = NEWSV(0,0);
3602 sv_upgrade(PL_toptarget, SVt_PVFM);
3603 sv_setpvn(PL_toptarget, "", 0);
3604 PL_bodytarget = NEWSV(0,0);
3605 sv_upgrade(PL_bodytarget, SVt_PVFM);
3606 sv_setpvn(PL_bodytarget, "", 0);
3607 PL_formtarget = PL_bodytarget;
3611 init_argv_symbols(argc,argv);
3613 if ((tmpgv = gv_fetchpv("0",TRUE, SVt_PV))) {
3614 #ifdef MACOS_TRADITIONAL
3615 /* $0 is not majick on a Mac */
3616 sv_setpv(GvSV(tmpgv),MacPerl_MPWFileName(PL_origfilename));
3618 sv_setpv(GvSV(tmpgv),PL_origfilename);
3619 magicname("0", "0", 1);
3622 if ((tmpgv = gv_fetchpv("\030",TRUE, SVt_PV))) {/* $^X */
3623 #ifdef HAS_PROCSELFEXE
3624 S_procself_val(aTHX_ GvSV(tmpgv), PL_origargv[0]);
3627 sv_setpv(GvSV(tmpgv), os2_execname(aTHX));
3629 sv_setpv(GvSV(tmpgv),PL_origargv[0]);
3633 if ((PL_envgv = gv_fetchpv("ENV",TRUE, SVt_PVHV))) {
3635 GvMULTI_on(PL_envgv);
3636 hv = GvHVn(PL_envgv);
3637 hv_magic(hv, Nullgv, PERL_MAGIC_env);
3638 #ifdef USE_ENVIRON_ARRAY
3639 /* Note that if the supplied env parameter is actually a copy
3640 of the global environ then it may now point to free'd memory
3641 if the environment has been modified since. To avoid this
3642 problem we treat env==NULL as meaning 'use the default'
3647 # ifdef USE_ITHREADS
3648 && PL_curinterp == aTHX
3652 environ[0] = Nullch;
3655 for (; *env; env++) {
3656 if (!(s = strchr(*env,'=')))
3663 sv = newSVpv(s+1, 0);
3664 (void)hv_store(hv, *env, s - *env, sv, 0);
3668 #endif /* USE_ENVIRON_ARRAY */
3671 if ((tmpgv = gv_fetchpv("$",TRUE, SVt_PV))) {
3672 SvREADONLY_off(GvSV(tmpgv));
3673 sv_setiv(GvSV(tmpgv), (IV)PerlProc_getpid());
3674 SvREADONLY_on(GvSV(tmpgv));
3676 #ifdef THREADS_HAVE_PIDS
3677 PL_ppid = (IV)getppid();
3680 /* touch @F array to prevent spurious warnings 20020415 MJD */
3682 (void) get_av("main::F", TRUE | GV_ADDMULTI);
3684 /* touch @- and @+ arrays to prevent spurious warnings 20020415 MJD */
3685 (void) get_av("main::-", TRUE | GV_ADDMULTI);
3686 (void) get_av("main::+", TRUE | GV_ADDMULTI);
3690 S_init_perllib(pTHX)
3695 s = PerlEnv_getenv("PERL5LIB");
3697 incpush(s, TRUE, TRUE);
3699 incpush(PerlEnv_getenv("PERLLIB"), FALSE, FALSE);
3701 /* Treat PERL5?LIB as a possible search list logical name -- the
3702 * "natural" VMS idiom for a Unix path string. We allow each
3703 * element to be a set of |-separated directories for compatibility.
3707 if (my_trnlnm("PERL5LIB",buf,0))
3708 do { incpush(buf,TRUE,TRUE); } while (my_trnlnm("PERL5LIB",buf,++idx));
3710 while (my_trnlnm("PERLLIB",buf,idx++)) incpush(buf,FALSE,FALSE);
3714 /* Use the ~-expanded versions of APPLLIB (undocumented),
3715 ARCHLIB PRIVLIB SITEARCH SITELIB VENDORARCH and VENDORLIB
3718 incpush(APPLLIB_EXP, TRUE, TRUE);
3722 incpush(ARCHLIB_EXP, FALSE, FALSE);
3724 #ifdef MACOS_TRADITIONAL
3727 SV * privdir = NEWSV(55, 0);
3728 char * macperl = PerlEnv_getenv("MACPERL");
3733 Perl_sv_setpvf(aTHX_ privdir, "%slib:", macperl);
3734 if (PerlLIO_stat(SvPVX(privdir), &tmpstatbuf) >= 0 && S_ISDIR(tmpstatbuf.st_mode))
3735 incpush(SvPVX(privdir), TRUE, FALSE);
3736 Perl_sv_setpvf(aTHX_ privdir, "%ssite_perl:", macperl);
3737 if (PerlLIO_stat(SvPVX(privdir), &tmpstatbuf) >= 0 && S_ISDIR(tmpstatbuf.st_mode))
3738 incpush(SvPVX(privdir), TRUE, FALSE);
3740 SvREFCNT_dec(privdir);
3743 incpush(":", FALSE, FALSE);
3746 # define PRIVLIB_EXP "/usr/local/lib/perl5:/usr/local/lib/perl"
3749 incpush(PRIVLIB_EXP, TRUE, FALSE);
3751 incpush(PRIVLIB_EXP, FALSE, FALSE);
3755 /* sitearch is always relative to sitelib on Windows for
3756 * DLL-based path intuition to work correctly */
3757 # if !defined(WIN32)
3758 incpush(SITEARCH_EXP, FALSE, FALSE);
3764 incpush(SITELIB_EXP, TRUE, FALSE); /* this picks up sitearch as well */
3766 incpush(SITELIB_EXP, FALSE, FALSE);
3770 #ifdef SITELIB_STEM /* Search for version-specific dirs below here */
3771 incpush(SITELIB_STEM, FALSE, TRUE);
3774 #ifdef PERL_VENDORARCH_EXP
3775 /* vendorarch is always relative to vendorlib on Windows for
3776 * DLL-based path intuition to work correctly */
3777 # if !defined(WIN32)
3778 incpush(PERL_VENDORARCH_EXP, FALSE, FALSE);
3782 #ifdef PERL_VENDORLIB_EXP
3784 incpush(PERL_VENDORLIB_EXP, TRUE, FALSE); /* this picks up vendorarch as well */
3786 incpush(PERL_VENDORLIB_EXP, FALSE, FALSE);
3790 #ifdef PERL_VENDORLIB_STEM /* Search for version-specific dirs below here */
3791 incpush(PERL_VENDORLIB_STEM, FALSE, TRUE);
3794 #ifdef PERL_OTHERLIBDIRS
3795 incpush(PERL_OTHERLIBDIRS, TRUE, TRUE);
3799 incpush(".", FALSE, FALSE);
3800 #endif /* MACOS_TRADITIONAL */
3803 #if defined(DOSISH) || defined(EPOC)
3804 # define PERLLIB_SEP ';'
3807 # define PERLLIB_SEP '|'
3809 # if defined(MACOS_TRADITIONAL)
3810 # define PERLLIB_SEP ','
3812 # define PERLLIB_SEP ':'
3816 #ifndef PERLLIB_MANGLE
3817 # define PERLLIB_MANGLE(s,n) (s)
3821 S_incpush(pTHX_ char *p, int addsubdirs, int addoldvers)
3823 SV *subdir = Nullsv;
3828 if (addsubdirs || addoldvers) {
3829 subdir = sv_newmortal();
3832 /* Break at all separators */
3834 SV *libdir = NEWSV(55,0);
3837 /* skip any consecutive separators */
3838 while ( *p == PERLLIB_SEP ) {
3839 /* Uncomment the next line for PATH semantics */
3840 /* av_push(GvAVn(PL_incgv), newSVpvn(".", 1)); */
3844 if ( (s = strchr(p, PERLLIB_SEP)) != Nullch ) {
3845 sv_setpvn(libdir, PERLLIB_MANGLE(p, (STRLEN)(s - p)),
3850 sv_setpv(libdir, PERLLIB_MANGLE(p, 0));
3851 p = Nullch; /* break out */
3853 #ifdef MACOS_TRADITIONAL
3854 if (!strchr(SvPVX(libdir), ':')) {
3857 sv_setpv(libdir, MacPerl_CanonDir(SvPVX(libdir), buf, 0));
3859 if (SvPVX(libdir)[SvCUR(libdir)-1] != ':')
3860 sv_catpv(libdir, ":");
3864 * BEFORE pushing libdir onto @INC we may first push version- and
3865 * archname-specific sub-directories.
3867 if (addsubdirs || addoldvers) {
3868 #ifdef PERL_INC_VERSION_LIST
3869 /* Configure terminates PERL_INC_VERSION_LIST with a NULL */
3870 const char *incverlist[] = { PERL_INC_VERSION_LIST };
3871 const char **incver;
3878 if ((unix = tounixspec_ts(SvPV(libdir,len),Nullch)) != Nullch) {
3880 while (unix[len-1] == '/') len--; /* Cosmetic */
3881 sv_usepvn(libdir,unix,len);
3884 PerlIO_printf(Perl_error_log,
3885 "Failed to unixify @INC element \"%s\"\n",
3889 #ifdef MACOS_TRADITIONAL
3890 #define PERL_AV_SUFFIX_FMT ""
3891 #define PERL_ARCH_FMT "%s:"
3892 #define PERL_ARCH_FMT_PATH PERL_FS_VER_FMT PERL_AV_SUFFIX_FMT
3894 #define PERL_AV_SUFFIX_FMT "/"
3895 #define PERL_ARCH_FMT "/%s"
3896 #define PERL_ARCH_FMT_PATH PERL_AV_SUFFIX_FMT PERL_FS_VER_FMT
3898 /* .../version/archname if -d .../version/archname */
3899 Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_ARCH_FMT_PATH PERL_ARCH_FMT,
3901 (int)PERL_REVISION, (int)PERL_VERSION,
3902 (int)PERL_SUBVERSION, ARCHNAME);
3903 if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
3904 S_ISDIR(tmpstatbuf.st_mode))
3905 av_push(GvAVn(PL_incgv), newSVsv(subdir));
3907 /* .../version if -d .../version */
3908 Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_ARCH_FMT_PATH, libdir,
3909 (int)PERL_REVISION, (int)PERL_VERSION,
3910 (int)PERL_SUBVERSION);
3911 if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
3912 S_ISDIR(tmpstatbuf.st_mode))
3913 av_push(GvAVn(PL_incgv), newSVsv(subdir));
3915 /* .../archname if -d .../archname */
3916 Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_ARCH_FMT, libdir, ARCHNAME);
3917 if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
3918 S_ISDIR(tmpstatbuf.st_mode))
3919 av_push(GvAVn(PL_incgv), newSVsv(subdir));
3922 #ifdef PERL_INC_VERSION_LIST
3924 for (incver = incverlist; *incver; incver++) {
3925 /* .../xxx if -d .../xxx */
3926 Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_ARCH_FMT, libdir, *incver);
3927 if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
3928 S_ISDIR(tmpstatbuf.st_mode))
3929 av_push(GvAVn(PL_incgv), newSVsv(subdir));
3935 /* finally push this lib directory on the end of @INC */
3936 av_push(GvAVn(PL_incgv), libdir);
3940 #ifdef USE_5005THREADS
3941 STATIC struct perl_thread *
3942 S_init_main_thread(pTHX)
3944 #if !defined(PERL_IMPLICIT_CONTEXT)
3945 struct perl_thread *thr;
3949 Newz(53, thr, 1, struct perl_thread);
3950 PL_curcop = &PL_compiling;
3951 thr->interp = PERL_GET_INTERP;
3952 thr->cvcache = newHV();
3953 thr->threadsv = newAV();
3954 /* thr->threadsvp is set when find_threadsv is called */
3955 thr->specific = newAV();
3956 thr->flags = THRf_R_JOINABLE;
3957 MUTEX_INIT(&thr->mutex);
3958 /* Handcraft thrsv similarly to mess_sv */
3959 New(53, PL_thrsv, 1, SV);
3960 Newz(53, xpv, 1, XPV);
3961 SvFLAGS(PL_thrsv) = SVt_PV;
3962 SvANY(PL_thrsv) = (void*)xpv;
3963 SvREFCNT(PL_thrsv) = 1 << 30; /* practically infinite */
3964 SvPVX(PL_thrsv) = (char*)thr;
3965 SvCUR_set(PL_thrsv, sizeof(thr));
3966 SvLEN_set(PL_thrsv, sizeof(thr));
3967 *SvEND(PL_thrsv) = '\0'; /* in the trailing_nul field */
3968 thr->oursv = PL_thrsv;
3969 PL_chopset = " \n-";
3972 MUTEX_LOCK(&PL_threads_mutex);
3978 MUTEX_UNLOCK(&PL_threads_mutex);
3980 #ifdef HAVE_THREAD_INTERN
3981 Perl_init_thread_intern(thr);
3984 #ifdef SET_THREAD_SELF
3985 SET_THREAD_SELF(thr);
3987 thr->self = pthread_self();
3988 #endif /* SET_THREAD_SELF */
3992 * These must come after the thread self setting
3993 * because sv_setpvn does SvTAINT and the taint
3994 * fields thread selfness being set.
3996 PL_toptarget = NEWSV(0,0);
3997 sv_upgrade(PL_toptarget, SVt_PVFM);
3998 sv_setpvn(PL_toptarget, "", 0);
3999 PL_bodytarget = NEWSV(0,0);
4000 sv_upgrade(PL_bodytarget, SVt_PVFM);
4001 sv_setpvn(PL_bodytarget, "", 0);
4002 PL_formtarget = PL_bodytarget;
4003 thr->errsv = newSVpvn("", 0);
4004 (void) find_threadsv("@"); /* Ensure $@ is initialised early */
4007 PL_peepp = MEMBER_TO_FPTR(Perl_peep);
4008 PL_regcompp = MEMBER_TO_FPTR(Perl_pregcomp);
4009 PL_regexecp = MEMBER_TO_FPTR(Perl_regexec_flags);
4010 PL_regint_start = MEMBER_TO_FPTR(Perl_re_intuit_start);
4011 PL_regint_string = MEMBER_TO_FPTR(Perl_re_intuit_string);
4012 PL_regfree = MEMBER_TO_FPTR(Perl_pregfree);
4014 PL_reginterp_cnt = 0;
4018 #endif /* USE_5005THREADS */
4021 Perl_call_list(pTHX_ I32 oldscope, AV *paramList)
4024 line_t oldline = CopLINE(PL_curcop);
4030 while (AvFILL(paramList) >= 0) {
4031 cv = (CV*)av_shift(paramList);
4033 if (paramList == PL_beginav) {
4034 /* save PL_beginav for compiler */
4035 if (! PL_beginav_save)
4036 PL_beginav_save = newAV();
4037 av_push(PL_beginav_save, (SV*)cv);
4039 else if (paramList == PL_checkav) {
4040 /* save PL_checkav for compiler */
4041 if (! PL_checkav_save)
4042 PL_checkav_save = newAV();
4043 av_push(PL_checkav_save, (SV*)cv);
4048 #ifdef PERL_FLEXIBLE_EXCEPTIONS
4049 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_vcall_list_body), cv);
4055 #ifndef PERL_FLEXIBLE_EXCEPTIONS
4059 (void)SvPV(atsv, len);
4062 PL_curcop = &PL_compiling;
4063 CopLINE_set(PL_curcop, oldline);
4064 if (paramList == PL_beginav)
4065 sv_catpv(atsv, "BEGIN failed--compilation aborted");
4067 Perl_sv_catpvf(aTHX_ atsv,
4068 "%s failed--call queue aborted",
4069 paramList == PL_checkav ? "CHECK"
4070 : paramList == PL_initav ? "INIT"
4072 while (PL_scopestack_ix > oldscope)
4075 Perl_croak(aTHX_ "%s", SvPVx(atsv, n_a));
4082 /* my_exit() was called */
4083 while (PL_scopestack_ix > oldscope)
4086 PL_curstash = PL_defstash;
4087 PL_curcop = &PL_compiling;
4088 CopLINE_set(PL_curcop, oldline);
4090 if (PL_statusvalue && !(PL_exit_flags & PERL_EXIT_EXPECTED)) {
4091 if (paramList == PL_beginav)
4092 Perl_croak(aTHX_ "BEGIN failed--compilation aborted");
4094 Perl_croak(aTHX_ "%s failed--call queue aborted",
4095 paramList == PL_checkav ? "CHECK"
4096 : paramList == PL_initav ? "INIT"
4103 PL_curcop = &PL_compiling;
4104 CopLINE_set(PL_curcop, oldline);
4107 PerlIO_printf(Perl_error_log, "panic: restartop\n");
4115 #ifdef PERL_FLEXIBLE_EXCEPTIONS
4117 S_vcall_list_body(pTHX_ va_list args)
4119 CV *cv = va_arg(args, CV*);
4120 return call_list_body(cv);
4125 S_call_list_body(pTHX_ CV *cv)
4127 PUSHMARK(PL_stack_sp);
4128 call_sv((SV*)cv, G_EVAL|G_DISCARD);
4133 Perl_my_exit(pTHX_ U32 status)
4135 DEBUG_S(PerlIO_printf(Perl_debug_log, "my_exit: thread %p, status %lu\n",
4136 thr, (unsigned long) status));
4145 STATUS_NATIVE_SET(status);
4152 Perl_my_failure_exit(pTHX)
4155 if (vaxc$errno & 1) {
4156 if (STATUS_NATIVE & 1) /* fortuitiously includes "-1" */
4157 STATUS_NATIVE_SET(44);
4160 if (!vaxc$errno && errno) /* unlikely */
4161 STATUS_NATIVE_SET(44);
4163 STATUS_NATIVE_SET(vaxc$errno);
4168 STATUS_POSIX_SET(errno);
4170 exitstatus = STATUS_POSIX >> 8;
4171 if (exitstatus & 255)
4172 STATUS_POSIX_SET(exitstatus);
4174 STATUS_POSIX_SET(255);
4181 S_my_exit_jump(pTHX)
4183 register PERL_CONTEXT *cx;
4188 SvREFCNT_dec(PL_e_script);
4189 PL_e_script = Nullsv;
4192 POPSTACK_TO(PL_mainstack);
4193 if (cxstack_ix >= 0) {
4196 POPBLOCK(cx,PL_curpm);
4204 read_e_script(pTHX_ int idx, SV *buf_sv, int maxlen)
4207 p = SvPVX(PL_e_script);
4208 nl = strchr(p, '\n');
4209 nl = (nl) ? nl+1 : SvEND(PL_e_script);
4211 filter_del(read_e_script);
4214 sv_catpvn(buf_sv, p, nl-p);
4215 sv_chop(PL_e_script, nl);