summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--MANIFEST2
-rw-r--r--cop.h79
-rw-r--r--dist/Storable/t/tied_items.t4
-rw-r--r--doio.c3
-rw-r--r--ext/XS-APItest/APItest.pm5
-rw-r--r--ext/XS-APItest/APItest.xs7
-rw-r--r--gv.c4
-rw-r--r--gv.h1
-rw-r--r--mg.c79
-rw-r--r--mg.h2
-rw-r--r--perl.h6
-rw-r--r--pp.c1
-rw-r--r--pp_ctl.c95
-rw-r--r--pp_hot.c28
-rw-r--r--pp_sys.c6
-rw-r--r--scope.c6
-rw-r--r--sv.c1
-rw-r--r--t/io/defout.t47
-rw-r--r--t/io/open.t16
-rw-r--r--t/op/magic.t11
-rw-r--r--t/op/svleak.t48
-rw-r--r--t/op/taint.t94
-rw-r--r--t/op/tie.t122
23 files changed, 562 insertions, 105 deletions
diff --git a/MANIFEST b/MANIFEST
index f3c16352b9..6363cc8cbe 100644
--- a/MANIFEST
+++ b/MANIFEST
@@ -4223,6 +4223,7 @@ t/io/argv.t See if ARGV stuff works
t/io/binmode.t See if binmode() works
t/io/crlf.t See if :crlf works
t/io/crlf_through.t See if pipe passes data intact with :crlf
+t/io/defout.t See if PL_defoutgv works
t/io/dup.t See if >& works right
t/io/errno.t See if $! is correctly set
t/io/fflush.t See if auto-flush on fork/exec/system/qx works
@@ -4483,6 +4484,7 @@ t/op/study.t See if study works
t/op/studytied.t See if study works with tied scalars
t/op/sub_lval.t See if lvalue subroutines work
t/op/sub.t See if subroutines work
+t/op/svleak.t See if stuff leaks SVs
t/op/switch.t See if switches (given/when) work
t/op/symbolcache.t See if undef/delete works on stashes with functions
t/op/sysio.t See if sysread and syswrite work
diff --git a/cop.h b/cop.h
index 13ce794ce2..6c51d73285 100644
--- a/cop.h
+++ b/cop.h
@@ -14,11 +14,12 @@
*/
/* A jmpenv packages the state required to perform a proper non-local jump.
- * Note that there is a start_env initialized when perl starts, and top_env
- * points to this initially, so top_env should always be non-null.
+ * Note that there is a PL_start_env initialized when perl starts, and
+ * PL_top_env points to this initially, so PL_top_env should always be
+ * non-null.
*
- * Existence of a non-null top_env->je_prev implies it is valid to call
- * longjmp() at that runlevel (we make sure start_env.je_prev is always
+ * Existence of a non-null PL_top_env->je_prev implies it is valid to call
+ * longjmp() at that runlevel (we make sure PL_start_env.je_prev is always
* null to ensure this).
*
* je_mustcatch, when set at any runlevel to TRUE, means eval ops must
@@ -99,9 +100,11 @@ typedef struct jmpenv JMPENV;
#define JMPENV_PUSH(v) \
STMT_START { \
- DEBUG_l(Perl_deb(aTHX_ "Setting up jumplevel %p, was %p at %s:%d\n", \
- (void*)&cur_env, (void*)PL_top_env, \
- __FILE__, __LINE__)); \
+ DEBUG_l({ \
+ int i = 0; JMPENV *p = PL_top_env; \
+ while (p) { i++; p = p->je_prev; } \
+ Perl_deb(aTHX_ "JUMPENV_PUSH level=%d at %s:%d\n", \
+ i, __FILE__, __LINE__);}) \
cur_env.je_prev = PL_top_env; \
OP_REG_TO_MEM; \
cur_env.je_ret = PerlProc_setjmp(cur_env.je_buf, SCOPE_SAVES_SIGNAL_MASK); \
@@ -113,15 +116,22 @@ typedef struct jmpenv JMPENV;
#define JMPENV_POP \
STMT_START { \
- DEBUG_l(Perl_deb(aTHX_ "popping jumplevel was %p, now %p at %s:%d\n", \
- (void*)PL_top_env, (void*)cur_env.je_prev, \
- __FILE__, __LINE__)); \
+ DEBUG_l({ \
+ int i = -1; JMPENV *p = PL_top_env; \
+ while (p) { i++; p = p->je_prev; } \
+ Perl_deb(aTHX_ "JUMPENV_POP level=%d at %s:%d\n", \
+ i, __FILE__, __LINE__);}) \
assert(PL_top_env == &cur_env); \
PL_top_env = cur_env.je_prev; \
} STMT_END
#define JMPENV_JUMP(v) \
STMT_START { \
+ DEBUG_l({ \
+ int i = -1; JMPENV *p = PL_top_env; \
+ while (p) { i++; p = p->je_prev; } \
+ Perl_deb(aTHX_ "JUMPENV_JUMP(%d) level=%d at %s:%d\n", \
+ (int)v, i, __FILE__, __LINE__);}) \
OP_REG_TO_MEM; \
if (PL_top_env->je_prev) \
PerlProc_longjmp(PL_top_env->je_buf, (v)); \
@@ -132,7 +142,15 @@ typedef struct jmpenv JMPENV;
} STMT_END
#define CATCH_GET (PL_top_env->je_mustcatch)
-#define CATCH_SET(v) (PL_top_env->je_mustcatch = (v))
+#define CATCH_SET(v) \
+ STMT_START { \
+ DEBUG_l( \
+ Perl_deb(aTHX_ \
+ "JUMPLEVEL set catch %d => %d (for %p) at %s:%d\n", \
+ PL_top_env->je_mustcatch, v, (void*)PL_top_env, \
+ __FILE__, __LINE__);) \
+ PL_top_env->je_mustcatch = (v); \
+ } STMT_END
#include "mydtrace.h"
@@ -550,6 +568,16 @@ struct block {
#define blk_loop cx_u.cx_blk.blk_u.blku_loop
#define blk_givwhen cx_u.cx_blk.blk_u.blku_givwhen
+#define DEBUG_CX(action) \
+ DEBUG_l(WITH_THX( \
+ Perl_deb(aTHX_ "CX %ld %s %s (scope %ld,%ld) at %s:%d\n", \
+ (long)cxstack_ix, \
+ action, \
+ PL_block_type[CxTYPE(&cxstack[cxstack_ix])], \
+ (long)PL_scopestack_ix, \
+ (long)(cxstack[cxstack_ix].blk_oldscopesp), \
+ __FILE__, __LINE__)));
+
/* Enter a block. */
#define PUSHBLOCK(cx,t,sp) CXINC, cx = &cxstack[cxstack_ix], \
cx->cx_type = t, \
@@ -559,28 +587,27 @@ struct block {
cx->blk_oldscopesp = PL_scopestack_ix, \
cx->blk_oldpm = PL_curpm, \
cx->blk_gimme = (U8)gimme; \
- DEBUG_l( PerlIO_printf(Perl_debug_log, "Entering block %ld, type %s\n", \
- (long)cxstack_ix, PL_block_type[CxTYPE(cx)]); )
+ DEBUG_CX("PUSH");
/* Exit a block (RETURN and LAST). */
-#define POPBLOCK(cx,pm) cx = &cxstack[cxstack_ix--], \
+#define POPBLOCK(cx,pm) \
+ DEBUG_CX("POP"); \
+ cx = &cxstack[cxstack_ix--], \
newsp = PL_stack_base + cx->blk_oldsp, \
PL_curcop = cx->blk_oldcop, \
PL_markstack_ptr = PL_markstack + cx->blk_oldmarksp, \
PL_scopestack_ix = cx->blk_oldscopesp, \
pm = cx->blk_oldpm, \
- gimme = cx->blk_gimme; \
- DEBUG_SCOPE("POPBLOCK"); \
- DEBUG_l( PerlIO_printf(Perl_debug_log, "Leaving block %ld, type %s\n", \
- (long)cxstack_ix+1,PL_block_type[CxTYPE(cx)]); )
+ gimme = cx->blk_gimme;
/* Continue a block elsewhere (NEXT and REDO). */
-#define TOPBLOCK(cx) cx = &cxstack[cxstack_ix], \
+#define TOPBLOCK(cx) \
+ DEBUG_CX("TOP"); \
+ cx = &cxstack[cxstack_ix], \
PL_stack_sp = PL_stack_base + cx->blk_oldsp, \
PL_markstack_ptr = PL_markstack + cx->blk_oldmarksp, \
PL_scopestack_ix = cx->blk_oldscopesp, \
- PL_curpm = cx->blk_oldpm; \
- DEBUG_SCOPE("TOPBLOCK");
+ PL_curpm = cx->blk_oldpm;
/* substitution context */
struct subst {
@@ -809,6 +836,11 @@ typedef struct stackinfo PERL_SI;
#define PUSHSTACKi(type) \
STMT_START { \
PERL_SI *next = PL_curstackinfo->si_next; \
+ DEBUG_l({ \
+ int i = 0; PERL_SI *p = PL_curstackinfo; \
+ while (p) { i++; p = p->si_prev; } \
+ Perl_deb(aTHX_ "push STACKINFO %d at %s:%d\n", \
+ i, __FILE__, __LINE__);}) \
if (!next) { \
next = new_stackinfo(32, 2048/sizeof(PERL_CONTEXT) - 1); \
next->si_prev = PL_curstackinfo; \
@@ -830,6 +862,11 @@ typedef struct stackinfo PERL_SI;
STMT_START { \
dSP; \
PERL_SI * const prev = PL_curstackinfo->si_prev; \
+ DEBUG_l({ \
+ int i = -1; PERL_SI *p = PL_curstackinfo; \
+ while (p) { i++; p = p->si_prev; } \
+ Perl_deb(aTHX_ "pop STACKINFO %d at %s:%d\n", \
+ i, __FILE__, __LINE__);}) \
if (!prev) { \
PerlIO_printf(Perl_error_log, "panic: POPSTACK\n"); \
my_exit(1); \
diff --git a/dist/Storable/t/tied_items.t b/dist/Storable/t/tied_items.t
index bd15e5cc4f..03e6cfe9ff 100644
--- a/dist/Storable/t/tied_items.t
+++ b/dist/Storable/t/tied_items.t
@@ -55,5 +55,5 @@ $ref2 = dclone $ref;
ok 5, $a_fetches == 0;
ok 6, $$ref2 eq $$ref;
ok 7, $$ref2 == 8;
-# I don't understand why it's 3 and not 2
-ok 8, $a_fetches == 3;
+# a bug in 5.12 and earlier caused an extra FETCH
+ok 8, $a_fetches == 2 || $a_fetches == 3 ;
diff --git a/doio.c b/doio.c
index 87f2da087d..eba7b54931 100644
--- a/doio.c
+++ b/doio.c
@@ -214,7 +214,8 @@ Perl_do_openn(pTHX_ GV *gv, register const char *oname, I32 len, int as_raw,
goto say_false;
}
#endif /* USE_STDIO */
- name = SvOK(*svp) ? savesvpv (*svp) : savepvs ("");
+ name = (SvOK(*svp) || SvGMAGICAL(*svp)) ?
+ savesvpv (*svp) : savepvs ("");
SAVEFREEPV(name);
}
else {
diff --git a/ext/XS-APItest/APItest.pm b/ext/XS-APItest/APItest.pm
index 11766f47ac..b1767931b9 100644
--- a/ext/XS-APItest/APItest.pm
+++ b/ext/XS-APItest/APItest.pm
@@ -24,6 +24,7 @@ our @EXPORT = qw( print_double print_int print_long
sv_setsv_cow_hashkey_core sv_setsv_cow_hashkey_notcore
rmagical_cast rmagical_flags
DPeek utf16_to_utf8 utf16_to_utf8_reversed pmflag my_exit
+ sv_count
);
our $VERSION = '0.17';
@@ -84,8 +85,8 @@ XS::APItest - Test the perl C API
=head1 ABSTRACT
-This module tests the perl C API. Currently tests that C<printf>
-works correctly.
+This module tests the perl C API. Also exposes various bit of the perl
+internals for the use of core test scripts.
=head1 DESCRIPTION
diff --git a/ext/XS-APItest/APItest.xs b/ext/XS-APItest/APItest.xs
index ede69949a1..328ddea42f 100644
--- a/ext/XS-APItest/APItest.xs
+++ b/ext/XS-APItest/APItest.xs
@@ -936,3 +936,10 @@ void
my_exit(int exitcode)
PPCODE:
my_exit(exitcode);
+
+I32
+sv_count()
+ CODE:
+ RETVAL = PL_sv_count;
+ OUTPUT:
+ RETVAL
diff --git a/gv.c b/gv.c
index becd1e909a..060d8e605a 100644
--- a/gv.c
+++ b/gv.c
@@ -1468,7 +1468,7 @@ Perl_gv_fullname4(pTHX_ SV *sv, const GV *gv, const char *prefix, bool keepmain)
void
Perl_gv_efullname4(pTHX_ SV *sv, const GV *gv, const char *prefix, bool keepmain)
{
- const GV * const egv = GvEGV(gv);
+ const GV * const egv = GvEGVx(gv);
PERL_ARGS_ASSERT_GV_EFULLNAME4;
@@ -2394,7 +2394,7 @@ Perl_gv_try_downgrade(pTHX_ GV *gv)
isGV_with_GP(gv) && GvGP(gv) &&
!GvINTRO(gv) && GvREFCNT(gv) == 1 &&
!GvSV(gv) && !GvAV(gv) && !GvHV(gv) && !GvIOp(gv) && !GvFORM(gv) &&
- GvEGV(gv) == gv && (stash = GvSTASH(gv))))
+ GvEGVx(gv) == gv && (stash = GvSTASH(gv))))
return;
cv = GvCV(gv);
if (!cv) {
diff --git a/gv.h b/gv.h
index caef3da82d..be4290dce4 100644
--- a/gv.h
+++ b/gv.h
@@ -114,6 +114,7 @@ Return the SV from the GV.
#define GvFILEGV(gv) (gv_fetchfile(GvFILE(gv)))
#define GvEGV(gv) (GvGP(gv)->gp_egv)
+#define GvEGVx(gv) (isGV_with_GP(gv) ? GvEGV(gv) : NULL)
#define GvENAME(gv) GvNAME(GvEGV(gv) ? GvEGV(gv) : gv)
#define GvESTASH(gv) GvSTASH(GvEGV(gv) ? GvEGV(gv) : gv)
diff --git a/mg.c b/mg.c
index 06c899e35e..3fb8ec43f4 100644
--- a/mg.c
+++ b/mg.c
@@ -991,8 +991,10 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg)
}
break;
case '^':
- if (GvIOp(PL_defoutgv))
- s = IoTOP_NAME(GvIOp(PL_defoutgv));
+ if (!isGV_with_GP(PL_defoutgv))
+ s = "";
+ else if (GvIOp(PL_defoutgv))
+ s = IoTOP_NAME(GvIOp(PL_defoutgv));
if (s)
sv_setpv(sv,s);
else {
@@ -1001,22 +1003,24 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg)
}
break;
case '~':
- if (GvIOp(PL_defoutgv))
+ if (!isGV_with_GP(PL_defoutgv))
+ s = "";
+ else if (GvIOp(PL_defoutgv))
s = IoFMT_NAME(GvIOp(PL_defoutgv));
if (!s)
s = GvENAME(PL_defoutgv);
sv_setpv(sv,s);
break;
case '=':
- if (GvIOp(PL_defoutgv))
+ if (GvIO(PL_defoutgv))
sv_setiv(sv, (IV)IoPAGE_LEN(GvIOp(PL_defoutgv)));
break;
case '-':
- if (GvIOp(PL_defoutgv))
+ if (GvIO(PL_defoutgv))
sv_setiv(sv, (IV)IoLINES_LEFT(GvIOp(PL_defoutgv)));
break;
case '%':
- if (GvIOp(PL_defoutgv))
+ if (GvIO(PL_defoutgv))
sv_setiv(sv, (IV)IoPAGE(GvIOp(PL_defoutgv)));
break;
case ':':
@@ -1027,7 +1031,7 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg)
sv_setiv(sv, (IV)CopARYBASE_get(PL_curcop));
break;
case '|':
- if (GvIOp(PL_defoutgv))
+ if (GvIO(PL_defoutgv))
sv_setiv(sv, (IV)(IoFLAGS(GvIOp(PL_defoutgv)) & IOf_FLUSH) != 0 );
break;
case '\\':
@@ -1691,7 +1695,7 @@ Perl_magic_getpack(pTHX_ SV *sv, MAGIC *mg)
{
PERL_ARGS_ASSERT_MAGIC_GETPACK;
- if (mg->mg_ptr)
+ if (mg->mg_type == PERL_MAGIC_tiedelem)
mg->mg_flags |= MGf_GSKIP;
magic_methpack(sv,mg,"FETCH");
return 0;
@@ -1701,12 +1705,33 @@ int
Perl_magic_setpack(pTHX_ SV *sv, MAGIC *mg)
{
dVAR; dSP;
+ MAGIC *tmg;
+ SV *val;
PERL_ARGS_ASSERT_MAGIC_SETPACK;
+ /* in the code C<$tied{foo} = $val>, the "thing" that gets passed to
+ * STORE() is not $val, but rather a PVLV (the sv in this call), whose
+ * public flags indicate its value based on copying from $val. Doing
+ * mg_set() on the PVLV temporarily does SvMAGICAL_off(), then calls us.
+ * So STORE()'s $_[2] arg is a temporarily disarmed PVLV. This goes
+ * wrong if $val happened to be tainted, as sv hasn't got magic
+ * enabled, even though taint magic is in the chain. In which case,
+ * fake up a temporary tainted value (this is easier than temporarily
+ * re-enabling magic on sv). */
+
+ if (PL_tainting && (tmg = mg_find(sv, PERL_MAGIC_taint))
+ && (tmg->mg_len & 1))
+ {
+ val = sv_mortalcopy(sv);
+ SvTAINTED_on(val);
+ }
+ else
+ val = sv;
+
ENTER;
PUSHSTACKi(PERLSI_MAGIC);
- magic_methcall(sv, mg, "STORE", G_SCALAR|G_DISCARD, 3, sv);
+ magic_methcall(sv, mg, "STORE", G_SCALAR|G_DISCARD, 3, val);
POPSTACK;
LEAVE;
return 0;
@@ -2502,29 +2527,37 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg)
IoLINES(GvIOp(PL_last_in_gv)) = SvIV(sv);
break;
case '^':
- Safefree(IoTOP_NAME(GvIOp(PL_defoutgv)));
- s = IoTOP_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
- IoTOP_GV(GvIOp(PL_defoutgv)) = gv_fetchsv(sv, GV_ADD, SVt_PVIO);
+ if (isGV_with_GP(PL_defoutgv)) {
+ Safefree(IoTOP_NAME(GvIOp(PL_defoutgv)));
+ s = IoTOP_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
+ IoTOP_GV(GvIOp(PL_defoutgv)) = gv_fetchsv(sv, GV_ADD, SVt_PVIO);
+ }
break;
case '~':
- Safefree(IoFMT_NAME(GvIOp(PL_defoutgv)));
- s = IoFMT_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
- IoFMT_GV(GvIOp(PL_defoutgv)) = gv_fetchsv(sv, GV_ADD, SVt_PVIO);
+ if (isGV_with_GP(PL_defoutgv)) {
+ Safefree(IoFMT_NAME(GvIOp(PL_defoutgv)));
+ s = IoFMT_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
+ IoFMT_GV(GvIOp(PL_defoutgv)) = gv_fetchsv(sv, GV_ADD, SVt_PVIO);
+ }
break;
case '=':
- IoPAGE_LEN(GvIOp(PL_defoutgv)) = (SvIV(sv));
+ if (isGV_with_GP(PL_defoutgv))
+ IoPAGE_LEN(GvIOp(PL_defoutgv)) = (SvIV(sv));
break;
case '-':
- IoLINES_LEFT(GvIOp(PL_defoutgv)) = (SvIV(sv));
- if (IoLINES_LEFT(GvIOp(PL_defoutgv)) < 0L)
- IoLINES_LEFT(GvIOp(PL_defoutgv)) = 0L;
+ if (isGV_with_GP(PL_defoutgv)) {
+ IoLINES_LEFT(GvIOp(PL_defoutgv)) = (SvIV(sv));
+ if (IoLINES_LEFT(GvIOp(PL_defoutgv)) < 0L)
+ IoLINES_LEFT(GvIOp(PL_defoutgv)) = 0L;
+ }
break;
case '%':
- IoPAGE(GvIOp(PL_defoutgv)) = (SvIV(sv));
+ if (isGV_with_GP(PL_defoutgv))
+ IoPAGE(GvIOp(PL_defoutgv)) = (SvIV(sv));
break;
case '|':
{
- IO * const io = GvIOp(PL_defoutgv);
+ IO * const io = GvIO(PL_defoutgv);
if(!io)
break;
if ((SvIV(sv)) == 0)
@@ -2612,7 +2645,6 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg)
#endif
#endif
PL_uid = PerlProc_getuid();
- PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
break;
case '>':
PL_euid = SvIV(sv);
@@ -2639,7 +2671,6 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg)
#endif
#endif
PL_euid = PerlProc_geteuid();
- PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
break;
case '(':
PL_gid = SvIV(sv);
@@ -2666,7 +2697,6 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg)
#endif
#endif
PL_gid = PerlProc_getgid();
- PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
break;
case ')':
#ifdef HAS_SETGROUPS
@@ -2728,7 +2758,6 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg)
#endif
#endif
PL_egid = PerlProc_getegid();
- PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
break;
case ':':
PL_chopset = SvPV_force(sv,len);
diff --git a/mg.h b/mg.h
index fcac411113..33628546c9 100644
--- a/mg.h
+++ b/mg.h
@@ -38,7 +38,7 @@ struct magic {
#define MGf_TAINTEDDIR 1 /* PERL_MAGIC_envelem only */
#define MGf_MINMATCH 1 /* PERL_MAGIC_regex_global only */
#define MGf_REFCOUNTED 2
-#define MGf_GSKIP 4
+#define MGf_GSKIP 4 /* skip further GETs until after next SET */
#define MGf_COPY 8 /* has an svt_copy MGVTBL entry */
#define MGf_DUP 0x10 /* has an svt_dup MGVTBL entry */
#define MGf_LOCAL 0x20 /* has an svt_local MGVTBL entry */
diff --git a/perl.h b/perl.h
index 5988e7845a..960ba1ae37 100644
--- a/perl.h
+++ b/perl.h
@@ -3818,8 +3818,10 @@ Gid_t getegid (void);
#define DEBUG_SCOPE(where) \
- DEBUG_l(WITH_THR(Perl_deb(aTHX_ "%s scope %ld at %s:%d\n", \
- where, (long)PL_scopestack_ix, __FILE__, __LINE__)));
+ DEBUG_l(WITH_THR( \
+ Perl_deb(aTHX_ "%s scope %ld (savestack=%ld) at %s:%d\n", \
+ where, (long)PL_scopestack_ix, (long)PL_savestack_ix, \
+ __FILE__, __LINE__)));
diff --git a/pp.c b/pp.c
index df8f048b2e..9565c6c473 100644
--- a/pp.c
+++ b/pp.c
@@ -3439,6 +3439,7 @@ PP(pp_sprintf)
dVAR; dSP; dMARK; dORIGMARK; dTARGET;
if (SvTAINTED(MARK[1]))
TAINT_PROPER("sprintf");
+ SvTAINTED_off(TARG);
do_sprintf(TARG, SP-MARK, MARK+1);
TAINT_IF(SvTAINTED(TARG));
SP = ORIGMARK;
diff --git a/pp_ctl.c b/pp_ctl.c
index de3487998f..bbb2d1587c 100644
--- a/pp_ctl.c
+++ b/pp_ctl.c
@@ -278,9 +278,11 @@ PP(pp_substcont)
if (cx->sb_iters > cx->sb_maxiters)
DIE(aTHX_ "Substitution loop");
+ SvGETMAGIC(TOPs); /* possibly clear taint on $1 etc: #67962 */
+
if (!(cx->sb_rxtainted & 2) && SvTAINTED(TOPs))
cx->sb_rxtainted |= 2;
- sv_catsv(dstr, POPs);
+ sv_catsv_nomg(dstr, POPs);
/* XXX: adjust for positive offsets of \G for instance s/(.)\G//g with positive pos() */
s -= RX_GOFS(rx);
@@ -1337,11 +1339,11 @@ S_dopoptolabel(pTHX_ const char *label)
{
const char *cx_label = CxLABEL(cx);
if (!cx_label || strNE(label, cx_label) ) {
- DEBUG_l(Perl_deb(aTHX_ "(Skipping label #%ld %s)\n",
+ DEBUG_l(Perl_deb(aTHX_ "(poptolabel(): skipping label at cx=%ld %s)\n",
(long)i, cx_label));
continue;
}
- DEBUG_l( Perl_deb(aTHX_ "(Found label #%ld %s)\n", (long)i, label));
+ DEBUG_l( Perl_deb(aTHX_ "(poptolabel(): found label at cx=%ld %s)\n", (long)i, label));
return i;
}
}
@@ -1410,7 +1412,7 @@ S_dopoptosub_at(pTHX_ const PERL_CONTEXT *cxstk, I32 startingblock)
case CXt_EVAL:
case CXt_SUB:
case CXt_FORMAT:
- DEBUG_l( Perl_deb(aTHX_ "(Found sub #%ld)\n", (long)i));
+ DEBUG_l( Perl_deb(aTHX_ "(dopoptosub_at(): found sub at cx=%ld)\n", (long)i));
return i;
}
}
@@ -1428,7 +1430,7 @@ S_dopoptoeval(pTHX_ I32 startingblock)
default:
continue;
case CXt_EVAL:
- DEBUG_l( Perl_deb(aTHX_ "(Found eval #%ld)\n", (long)i));
+ DEBUG_l( Perl_deb(aTHX_ "(dopoptoeval(): found eval at cx=%ld)\n", (long)i));
return i;
}
}
@@ -1457,7 +1459,7 @@ S_dopoptoloop(pTHX_ I32 startingblock)
case CXt_LOOP_LAZYSV:
case CXt_LOOP_FOR:
case CXt_LOOP_PLAIN:
- DEBUG_l( Perl_deb(aTHX_ "(Found loop #%ld)\n", (long)i));
+ DEBUG_l( Perl_deb(aTHX_ "(dopoptoloop(): found loop at cx=%ld)\n", (long)i));
return i;
}
}
@@ -1475,7 +1477,7 @@ S_dopoptogiven(pTHX_ I32 startingblock)
default:
continue;
case CXt_GIVEN:
- DEBUG_l( Perl_deb(aTHX_ "(Found given #%ld)\n", (long)i));
+ DEBUG_l( Perl_deb(aTHX_ "(dopoptogiven(): found given at cx=%ld)\n", (long)i));
return i;
case CXt_LOOP_PLAIN:
assert(!CxFOREACHDEF(cx));
@@ -1484,7 +1486,7 @@ S_dopoptogiven(pTHX_ I32 startingblock)
case CXt_LOOP_LAZYSV:
case CXt_LOOP_FOR:
if (CxFOREACHDEF(cx)) {
- DEBUG_l( Perl_deb(aTHX_ "(Found foreach #%ld)\n", (long)i));
+ DEBUG_l( Perl_deb(aTHX_ "(dopoptogiven(): found foreach at cx=%ld)\n", (long)i));
return i;
}
}
@@ -1503,7 +1505,7 @@ S_dopoptowhen(pTHX_ I32 startingblock)
default:
continue;
case CXt_WHEN:
- DEBUG_l( Perl_deb(aTHX_ "(Found when #%ld)\n", (long)i));
+ DEBUG_l( Perl_deb(aTHX_ "(dopoptowhen(): found when at cx=%ld)\n", (long)i));
return i;
}
}
@@ -1519,8 +1521,7 @@ Perl_dounwind(pTHX_ I32 cxix)
while (cxstack_ix > cxix) {
SV *sv;
register PERL_CONTEXT *cx = &cxstack[cxstack_ix];
- DEBUG_l(PerlIO_printf(Perl_debug_log, "Unwinding block %ld, type %s\n",
- (long) cxstack_ix, PL_block_type[CxTYPE(cx)]));
+ DEBUG_CX("UNWIND"); \
/* Note: we don't need to restore the base context info till the end. */
switch (CxTYPE(cx)) {
case CXt_SUBST:
@@ -1652,6 +1653,10 @@ Perl_die_where(pTHX_ SV *msv)
SV * const nsv = cx->blk_eval.old_namesv;
(void)hv_store(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv),
&PL_sv_undef, 0);
+ /* note that unlike pp_entereval, pp_require isn't
+ * supposed to trap errors. So now that we've popped the
+ * EVAL that pp_require pushed, and processed the error
+ * message, rethrow the error */
DIE(aTHX_ "%sCompilation failed in require",
*msg ? msg : "Unknown error\n");
}
@@ -3040,6 +3045,35 @@ Perl_find_runcv(pTHX_ U32 *db_seqp)
}
+/* Run yyparse() in a setjmp wrapper. Returns:
+ * 0: yyparse() successful
+ * 1: yyparse() failed
+ * 3: yyparse() died
+ */
+STATIC int
+S_try_yyparse(pTHX)
+{
+ int ret;
+ dJMPENV;
+
+ assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
+ JMPENV_PUSH(ret);
+ switch (ret) {
+ case 0:
+ ret = yyparse() ? 1 : 0;
+ break;
+ case 3:
+ break;
+ default:
+ JMPENV_POP;
+ JMPENV_JUMP(ret);
+ /* NOTREACHED */
+ }
+ JMPENV_POP;
+ return ret;
+}
+
+
/* Compile a require/do, an eval '', or a /(?{...})/.
* In the last case, startop is non-null, and contains the address of
* a pointer that should be set to the just-compiled code.
@@ -3054,8 +3088,10 @@ S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq)
{
dVAR; dSP;
OP * const saveop = PL_op;
+ bool in_require = (saveop && saveop->op_type == OP_REQUIRE);
+ int yystatus;
- PL_in_eval = ((saveop && saveop->op_type == OP_REQUIRE)
+ PL_in_eval = (in_require
? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL))
: EVAL_INEVAL);
@@ -3107,27 +3143,39 @@ S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq)
PL_in_eval |= EVAL_KEEPERR;
else
CLEAR_ERRSV();
- if (yyparse() || PL_parser->error_count || !PL_eval_root) {
+
+ /* note that yyparse() may raise an exception, e.g. C<BEGIN{die}>,
+ * so honour CATCH_GET and trap it here if necessary */
+
+ yystatus = (!in_require && CATCH_GET) ? S_try_yyparse(aTHX) : yyparse();
+
+ if (yystatus || PL_parser->error_count || !PL_eval_root) {
SV **newsp; /* Used by POPBLOCK. */
PERL_CONTEXT *cx = &cxstack[cxstack_ix];
- I32 optype = 0; /* Might be reset by POPEVAL. */
+ I32 optype; /* Used by POPEVAL. */
const char *msg;
+ PERL_UNUSED_VAR(newsp);
+ PERL_UNUSED_VAR(optype);
+
PL_op = saveop;
if (PL_eval_root) {
op_free(PL_eval_root);
PL_eval_root = NULL;
}
- SP = PL_stack_base + POPMARK; /* pop original mark */
- if (!startop) {
- POPBLOCK(cx,PL_curpm);
- POPEVAL(cx);
+ if (yystatus != 3) {
+ SP = PL_stack_base + POPMARK; /* pop original mark */
+ if (!startop) {
+ POPBLOCK(cx,PL_curpm);
+ POPEVAL(cx);
+ }
}
lex_end();
- LEAVE_with_name("eval"); /* pp_entereval knows about this LEAVE. */
+ if (yystatus != 3)
+ LEAVE_with_name("eval"); /* pp_entereval knows about this LEAVE. */
msg = SvPVx_nolen_const(ERRSV);
- if (optype == OP_REQUIRE) {
+ if (in_require) {
const SV * const nsv = cx->blk_eval.old_namesv;
(void)hv_store(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv),
&PL_sv_undef, 0);
@@ -3135,8 +3183,10 @@ S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq)
*msg ? msg : "Unknown error\n");
}
else if (startop) {
- POPBLOCK(cx,PL_curpm);
- POPEVAL(cx);
+ if (yystatus != 3) {
+ POPBLOCK(cx,PL_curpm);
+ POPEVAL(cx);
+ }
Perl_croak(aTHX_ "%sCompilation failed in regexp",
(*msg ? msg : "Unknown error\n"));
}
@@ -3145,7 +3195,6 @@ S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq)
sv_setpvs(ERRSV, "Compilation error");
}
}
- PERL_UNUSED_VAR(newsp);
PUSHs(&PL_sv_undef);
PUTBACK;
return FALSE;
diff --git a/pp_hot.c b/pp_hot.c
index 3371e889ea..70d35568fd 100644
--- a/pp_hot.c
+++ b/pp_hot.c
@@ -658,7 +658,7 @@ PP(pp_aelemfast)
SV *sv = (svp ? *svp : &PL_sv_undef);
EXTEND(SP, 1);
if (!lval && SvGMAGICAL(sv)) /* see note in pp_helem() */
- sv = sv_mortalcopy(sv);
+ mg_get(sv);
PUSHs(sv);
RETURN;
}
@@ -734,7 +734,7 @@ PP(pp_print)
RETURN;
}
if (!(io = GvIO(gv))) {
- if ((GvEGV(gv)) && (io = GvIO(GvEGV(gv)))
+ if ((GvEGVx(gv)) && (io = GvIO(GvEGV(gv)))
&& (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar)))
goto had_magic;
if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
@@ -893,7 +893,7 @@ PP(pp_rv2av)
SV ** const svp = av_fetch(av, i, FALSE);
/* See note in pp_helem, and bug id #27839 */
SP[i+1] = svp
- ? SvGMAGICAL(*svp) ? sv_mortalcopy(*svp) : *svp
+ ? SvGMAGICAL(*svp) ? (mg_get(*svp), *svp) : *svp
: &PL_sv_undef;
}
}
@@ -1840,14 +1840,20 @@ PP(pp_helem)
vivify_ref(*svp, PL_op->op_private & OPpDEREF);
}
sv = (svp ? *svp : &PL_sv_undef);
- /* This makes C<local $tied{foo} = $tied{foo}> possible.
- * Pushing the magical RHS on to the stack is useless, since
- * that magic is soon destined to be misled by the local(),
- * and thus the later pp_sassign() will fail to mg_get() the
- * old value. This should also cure problems with delayed
- * mg_get()s. GSAR 98-07-03 */
+ /* Originally this did a conditional C<sv = sv_mortalcopy(sv)>; this
+ * was to make C<local $tied{foo} = $tied{foo}> possible.
+ * However, it seems no longer to be needed for that purpose, and
+ * introduced a new bug: stuff like C<while ($hash{taintedval} =~ /.../g>
+ * would loop endlessly since the pos magic is getting set on the
+ * mortal copy and lost. However, the copy has the effect of
+ * triggering the get magic, and losing it altogether made things like
+ * c<$tied{foo};> in void context no longer do get magic, which some
+ * code relied on. Also, delayed triggering of magic on @+ and friends
+ * meant the original regex may be out of scope by now. So as a
+ * compromise, do the get magic here. (The MGf_GSKIP flag will stop it
+ * being called too many times). */
if (!lval && SvGMAGICAL(sv))
- sv = sv_mortalcopy(sv);
+ mg_get(sv);
PUSHs(sv);
RETURN;
}
@@ -2983,7 +2989,7 @@ PP(pp_aelem)
}
sv = (svp ? *svp : &PL_sv_undef);
if (!lval && SvGMAGICAL(sv)) /* see note in pp_helem() */
- sv = sv_mortalcopy(sv);
+ mg_get(sv);
PUSHs(sv);
RETURN;
}
diff --git a/pp_sys.c b/pp_sys.c
index e7cdb594b8..8dd8bc0635 100644
--- a/pp_sys.c
+++ b/pp_sys.c
@@ -1170,11 +1170,11 @@ PP(pp_select)
dVAR; dSP; dTARGET;
HV *hv;
GV * const newdefout = (PL_op->op_private > 0) ? (MUTABLE_GV(POPs)) : NULL;
- GV * egv = GvEGV(PL_defoutgv);
+ GV * egv = GvEGVx(PL_defoutgv);
if (!egv)
egv = PL_defoutgv;
- hv = GvSTASH(egv);
+ hv = isGV_with_GP(egv) ? GvSTASH(egv) : NULL;
if (! hv)
XPUSHs(&PL_sv_undef);
else {
@@ -2017,7 +2017,7 @@ PP(pp_eof)
if (MAXARG)
gv = PL_last_in_gv = MUTABLE_GV(POPs); /* eof(FH) */
else if (PL_op->op_flags & OPf_SPECIAL)
- gv = PL_last_in_gv = GvEGV(PL_argvgv); /* eof() - ARGV magic */
+ gv = PL_last_in_gv = GvEGVx(PL_argvgv); /* eof() - ARGV magic */
else
gv = PL_last_in_gv; /* eof */
diff --git a/scope.c b/scope.c
index ed4c835de9..de7d20593f 100644
--- a/scope.c
+++ b/scope.c
@@ -619,7 +619,7 @@ Perl_save_aelem_flags(pTHX_ AV *av, I32 idx, SV **sptr, const U32 flags)
* won't actually be stored in the array - so it won't get
* reaped when the localize ends. Ensure it gets reaped by
* mortifying it instead. DAPM */
- if (SvTIED_mg(sv, PERL_MAGIC_tiedelem))
+ if (SvTIED_mg(av, PERL_MAGIC_tied))
sv_2mortal(sv);
}
@@ -645,7 +645,7 @@ Perl_save_helem_flags(pTHX_ HV *hv, SV *key, SV **sptr, const U32 flags)
* won't actually be stored in the hash - so it won't get
* reaped when the localize ends. Ensure it gets reaped by
* mortifying it instead. DAPM */
- if (SvTIED_mg(sv, PERL_MAGIC_tiedelem))
+ if (SvTIED_mg(hv, PERL_MAGIC_tied))
sv_2mortal(sv);
}
@@ -694,6 +694,8 @@ Perl_leave_scope(pTHX_ I32 base)
if (base < -1)
Perl_croak(aTHX_ "panic: corrupt saved stack index");
+ DEBUG_l(Perl_deb(aTHX_ "savestack: releasing items %ld -> %ld\n",
+ (long)PL_savestack_ix, (long)base));
while (PL_savestack_ix > base) {
TAINT_NOT;
diff --git a/sv.c b/sv.c
index b6c03ed7ea..5759b2b4c6 100644
--- a/sv.c
+++ b/sv.c
@@ -10431,6 +10431,7 @@ Perl_sv_vcatpvfn(pTHX_ SV *const sv, const char *const pat, const STRLEN patlen,
goto vector;
}
}
+ SvTAINT(sv);
}
/* =========================================================================
diff --git a/t/io/defout.t b/t/io/defout.t
new file mode 100644
index 0000000000..d99b39bd6c
--- /dev/null
+++ b/t/io/defout.t
@@ -0,0 +1,47 @@
+#!./perl
+#
+# tests for default output handle
+
+# DAPM 30/4/10 this area seems to have been undertested. For now, the only
+# tests are ensuring things don't crash when PL_defoutgv isn't a GV;
+# it probably needs expanding at some point to cover other stuff.
+
+BEGIN {
+ chdir 't';
+ @INC = '../lib';
+ require './test.pl';
+}
+
+plan tests => 16;
+
+
+my $stderr = *STDERR;
+select($stderr);
+$stderr = 1; # whoops, PL_defoutgv no longer a GV!
+
+# note that in the tests below, the return values aren't as important
+# as the fact that they don't crash
+
+ok !print(""), 'print';
+ok !select(), 'select';
+$a = 'fooo';
+format STDERR =
+#@<<
+$a;
+.
+ok ! write(), 'write';
+
+is($^, "", '$^');
+is($~, "", '$~');
+is($=, undef, '$=');
+is($-, undef, '$-');
+is($%, undef, '$%');
+is($|, 0, '$|');
+$^ = 1; pass '$^ = 1';
+$~ = 1; pass '$~ = 1';
+$= = 1; pass '$= = 1';
+$- = 1; pass '$- = 1';
+$% = 1; pass '$% = 1';
+$| = 1; pass '$| = 1';
+ok !close(), 'close';
+
diff --git a/t/io/open.t b/t/io/open.t
index 1a5832747d..443aab33b6 100644
--- a/t/io/open.t
+++ b/t/io/open.t
@@ -10,7 +10,7 @@ $| = 1;
use warnings;
use Config;
-plan tests => 108;
+plan tests => 109;
my $Perl = which_perl();
@@ -310,3 +310,17 @@ fresh_perl_is(
eval { open $99, "foo" };
like($@, qr/Modification of a read-only value attempted/, "readonly fh");
+
+# [perl#73626] mg_get wasn't run on the pipe arg
+
+{
+ package p73626;
+ sub TIESCALAR { bless {} }
+ sub FETCH { "$Perl -e 1"}
+
+ tie my $p, 'p73626';
+
+ package main;
+
+ ok( open(my $f, '-|', $p), 'open -| magic');
+}
diff --git a/t/op/magic.t b/t/op/magic.t
index 3df3e4bab0..5a2733fd3a 100644
--- a/t/op/magic.t
+++ b/t/op/magic.t
@@ -12,7 +12,7 @@ BEGIN {
use warnings;
use Config;
-plan (tests => 80);
+plan (tests => 81);
$Is_MSWin32 = $^O eq 'MSWin32';
$Is_NetWare = $^O eq 'NetWare';
@@ -443,6 +443,15 @@ is "@+", "10 1 6 10";
};
my @y = f();
is $x, "@y", "return a magic array ($x) vs (@y)";
+
+ sub f2 {
+ "abc" =~ /(?<foo>.)./;
+ my @h = %+;
+ $x = "@h";
+ return %+;
+ };
+ @y = f();
+ is $x, "@y", "return a magic hash ($x) vs (@y)";
}
# Test for bug [perl #36434]
diff --git a/t/op/svleak.t b/t/op/svleak.t
new file mode 100644
index 0000000000..669b00e0a3
--- /dev/null
+++ b/t/op/svleak.t
@@ -0,0 +1,48 @@
+#!./perl
+
+# A place to put some simple leak tests. Uses XS::APItest to make
+# PL_sv_count available, allowing us to run a bit a code multiple times and
+# see if the count increases.
+
+BEGIN {
+ chdir 't';
+ @INC = '../lib';
+ require './test.pl';
+
+ eval { require XS::APItest; XS::APItest->import('sv_count'); 1 }
+ or skip_all("XS::APItest not available");
+}
+
+plan tests => 4;
+
+# run some code N times. If the number of SVs at the end of loop N is
+# greater than (N-1)*delta at the end of loop 1, we've got a leak
+#
+sub leak {
+ my ($n, $delta, $code, @rest) = @_;
+ my $sv0 = 0;
+ my $sv1 = 0;
+ for my $i (1..$n) {
+ &$code();
+ $sv1 = sv_count();
+ $sv0 = $sv1 if $i == 1;
+ }
+ cmp_ok($sv1-$sv0, '<=', ($n-1)*$delta, @rest);
+}
+
+my @a;
+
+leak(5, 0, sub {}, "basic check 1 of leak test infrastructure");
+leak(5, 0, sub {push @a,1;pop @a}, "basic check 2 of leak test infrastructure");
+leak(5, 1, sub {push @a,1;}, "basic check 3 of leak test infrastructure");
+
+sub TIEARRAY { bless [], $_[0] }
+sub FETCH { $_[0]->[$_[1]] }
+sub STORE { $_[0]->[$_[1]] = $_[2] }
+
+# local $tied_elem[..] leaks <20020502143736.N16831@dansat.data-plan.com>"
+{
+ tie my @a, 'main';
+ leak(5, 0, sub {local $a[0]}, "local \$tied[0]");
+}
+
diff --git a/t/op/taint.t b/t/op/taint.t
index 161073deb6..e3a5712913 100644
--- a/t/op/taint.t
+++ b/t/op/taint.t
@@ -17,7 +17,7 @@ use Config;
use File::Spec::Functions;
BEGIN { require './test.pl'; }
-plan tests => 302;
+plan tests => 325;
$| = 1;
@@ -1128,13 +1128,19 @@ TERNARY_CONDITIONALS: {
{
my @a;
- local $::TODO = 1;
- $a[0] = $^X;
- my $i = 0;
- while($a[0]=~ m/(.)/g ) {
- last if $i++ > 10000;
- }
- cmp_ok $i, '<', 10000, "infinite m//g";
+ $a[0] = $^X . '-';
+ $a[0]=~ m/(.)/g;
+ cmp_ok pos($a[0]), '>', 0, "infinite m//g on arrays (aelemfast)";
+
+ my $i = 1;
+ $a[$i] = $^X . '-';
+ $a[$i]=~ m/(.)/g;
+ cmp_ok pos($a[$i]), '>', 0, "infinite m//g on arrays (aelem)";
+
+ my %h;
+ $h{a} = $^X . '-';
+ $h{a}=~ m/(.)/g;
+ cmp_ok pos($h{a}), '>', 0, "infinite m//g on hashes (helem)";
}
SKIP:
@@ -1318,6 +1324,78 @@ foreach my $ord (78, 163, 256) {
unlike($err, qr/^\d+$/, 'tainted $!');
}
+{
+ # #6758: tainted values become untainted in tied hashes
+ # (also applies to other value magic such as pos)
+
+
+ package P6758;
+
+ sub TIEHASH { bless {} }
+ sub TIEARRAY { bless {} }
+
+ my $i = 0;
+
+ sub STORE {
+ main::ok(main::tainted($_[1]), "tied arg1 tainted");
+ main::ok(main::tainted($_[2]), "tied arg2 tainted");
+ $i++;
+ }
+
+ package main;
+
+ my ($k,$v) = qw(1111 val);
+ taint_these($k,$v);
+ tie my @array, 'P6758';
+ tie my %hash , 'P6758';
+ $array[$k] = $v;
+ $hash{$k} = $v;
+ ok $i == 2, "tied STORE called correct number of times";
+}
+
+# Bug RT #45167 the return value of sprintf sometimes wasn't tainted
+# when the args were tainted. This only occured on the first use of
+# sprintf; after that, its TARG has taint magic attached, so setmagic
+# at the end works. That's why there are multiple sprintf's below, rather
+# than just one wrapped in an inner loop. Also, any plantext betwerrn
+# fprmat entires would correctly cause tainting to get set. so test with
+# "%s%s" rather than eg "%s %s".
+
+{
+ for my $var1 ($TAINT, "123") {
+ for my $var2 ($TAINT0, "456") {
+ my @s;
+ push @s, sprintf '%s', $var1, $var2;
+ push @s, sprintf ' %s', $var1, $var2;
+ push @s, sprintf '%s%s', $var1, $var2;
+ for (0..2) {
+ ok( !(
+ tainted($s[$_]) xor
+ (tainted($var1) || ($_==2 && tainted($var2)))
+ ),
+ "sprintf fmt$_, '$var1', '$var2'");
+ }
+ }
+ }
+}
+
+
+# Bug RT #67962: old tainted $1 gets treated as tainted
+# in next untainted # match
+
+{
+ use re 'taint';
+ "abc".$TAINT =~ /(.*)/; # make $1 tainted
+ ok(tainted($1), '$1 should be tainted');
+
+ my $untainted = "abcdef";
+ ok(!tainted($untainted), '$untainted should be untainted');
+ $untainted =~ s/(abc)/$1/;
+ ok(!tainted($untainted), '$untainted should still be untainted');
+ $untainted =~ s/(abc)/x$1/;
+ ok(!tainted($untainted), '$untainted should yet still be untainted');
+}
+
# This may bomb out with the alarm signal so keep it last
SKIP: {
diff --git a/t/op/tie.t b/t/op/tie.t
index 8daa8b06f1..2ef710167f 100644
--- a/t/op/tie.t
+++ b/t/op/tie.t
@@ -646,3 +646,125 @@ sub TIEHASH { bless [], 'main' }
}
print "tied\n" if tied %h;
EXPECT
+########
+# RT 20727: PL_defoutgv is left as a tied element
+sub TIESCALAR { return bless {}, 'main' }
+
+sub STORE {
+ select($_[1]);
+ $_[1] = 1;
+ select(); # this used to coredump or assert fail
+}
+tie $SELECT, 'main';
+$SELECT = *STDERR;
+EXPECT
+########
+# RT 23810: eval in die in FETCH can corrupt context stack
+
+my $file = 'rt23810.pm';
+
+my $e;
+my $s;
+
+sub do_require {
+ my ($str, $eval) = @_;
+ open my $fh, '>', $file or die "Can't create $file: $!\n";
+ print $fh $str;
+ close $fh;
+ if ($eval) {
+ $s .= '-ERQ';
+ eval { require $pm; $s .= '-ENDE' }
+ }
+ else {
+ $s .= '-RQ';
+ require $pm;
+ }
+ $s .= '-ENDRQ';
+ unlink $file;
+}
+
+sub TIEHASH { bless {} }
+
+sub FETCH {
+ # 10 or more syntax errors makes yyparse croak()
+ my $bad = q{$x+;$x+;$x+;$x+;$x+;$x+;$x+;$x+;$x+$x+;$x+;$x+;$x+;$x+;;$x+;};
+
+ if ($_[1] eq 'eval') {
+ $s .= 'EVAL';
+ eval q[BEGIN { die; $s .= '-X1' }];
+ $s .= '-BD';
+ eval q[BEGIN { $x+ }];
+ $s .= '-BS';
+ eval '$x+';
+ $s .= '-E1';
+ $s .= '-S1' while $@ =~ /syntax error at/g;
+ eval $bad;
+ $s .= '-E2';
+ $s .= '-S2' while $@ =~ /syntax error at/g;
+ }
+ elsif ($_[1] eq 'require') {
+ $s .= 'REQUIRE';
+ my @text = (
+ q[BEGIN { die; $s .= '-X1' }],
+ q[BEGIN { $x+ }],
+ '$x+',
+ $bad
+ );
+ for my $i (0..$#text) {
+ $s .= "-$i";
+ do_require($txt[$i], 0) if $e;;
+ do_require($txt[$i], 1);
+ }
+ }
+ elsif ($_[1] eq 'exit') {
+ eval q[exit(0); print "overshot eval\n"];
+ }
+ else {
+ print "unknown key: '$_[1]'\n";
+ }
+ return "-R";
+}
+my %foo;
+tie %foo, "main";
+
+for my $action(qw(eval require)) {
+ $s = ''; $e = 0; $s .= main->FETCH($action); print "$action: s0=$s\n";
+ $s = ''; $e = 1; eval { $s .= main->FETCH($action)}; print "$action: s1=$s\n";
+ $s = ''; $e = 0; $s .= $foo{$action}; print "$action: s2=$s\n";
+ $s = ''; $e = 1; eval { $s .= $foo{$action}}; print "$action: s3=$s\n";
+}
+1 while unlink $file;
+
+$foo{'exit'};
+print "overshot main\n"; # shouldn't reach here
+
+EXPECT
+eval: s0=EVAL-BD-BS-E1-S1-E2-S2-S2-S2-S2-S2-S2-S2-S2-S2-S2-R
+eval: s1=EVAL-BD-BS-E1-S1-E2-S2-S2-S2-S2-S2-S2-S2-S2-S2-S2-R
+eval: s2=EVAL-BD-BS-E1-S1-E2-S2-S2-S2-S2-S2-S2-S2-S2-S2-S2-R
+eval: s3=EVAL-BD-BS-E1-S1-E2-S2-S2-S2-S2-S2-S2-S2-S2-S2-S2-R
+require: s0=REQUIRE-0-ERQ-ENDRQ-1-ERQ-ENDRQ-2-ERQ-ENDRQ-3-ERQ-ENDRQ-R
+require: s1=REQUIRE-0-RQ
+require: s2=REQUIRE-0-ERQ-ENDRQ-1-ERQ-ENDRQ-2-ERQ-ENDRQ-3-ERQ-ENDRQ-R
+require: s3=REQUIRE-0-RQ
+########
+# RT 8857: STORE incorrectly invoked for local($_) on aliased tied array
+# element
+
+sub TIEARRAY { bless [], $_[0] }
+sub TIEHASH { bless [], $_[0] }
+sub FETCH { $_[0]->[$_[1]] }
+sub STORE { $_[0]->[$_[1]] = $_[2] }
+
+
+sub f {
+ local $_[0];
+}
+tie @a, 'main';
+tie %h, 'main';
+
+foreach ($a[0], $h{a}) {
+ f($_);
+}
+# on failure, chucks up 'premature free' etc messages
+EXPECT
View Lorry Controller Status