In perl.git, the branch blead has been updated
<http://perl5.git.perl.org/perl.git/commitdiff/9274aefd575ecb452e8b3e33659780c198ca43ab?hp=798bda5901ecadfc40314834ece57421e2c50146>
- Log -----------------------------------------------------------------
commit 9274aefd575ecb452e8b3e33659780c198ca43ab
Author: David Mitchell <da...@iabyn.com>
Date: Thu Feb 17 14:50:04 2011 +0000
taint REGEX SVs as well as refs to them
Now that REGEX is actually a first-class SV type, we can taint
the regex SV directly, as well as the RV pointing to it.
This means that this now taints:
$rr = qr/$tainted/;
$r = $$r;
/$r/;
M pp_ctl.c
M pp_hot.c
M t/op/taint.t
commit 5e79dfb9cd4496df40e823bec270c4bcde98db07
Author: David Mitchell <da...@iabyn.com>
Date: Thu Feb 17 14:17:13 2011 +0000
pp_subst: exit earlier after failed match
If the match fails, don't bother to execute some code that prepares the
source and replacement strings for a substitution (e.g. matching
UTF8-ness).
(This is an enhancement to ff6e92e827a143094fdf3af374056b524759194b)
M pp_hot.c
commit 0ab462a656aa799cb05352f5ff7596c9bf6893ee
Author: David Mitchell <da...@iabyn.com>
Date: Thu Feb 17 14:13:04 2011 +0000
tweak the new pattern taint description
M pp_hot.c
-----------------------------------------------------------------------
Summary of changes:
pp_ctl.c | 4 +++-
pp_hot.c | 44 ++++++++++++++++++++++++--------------------
t/op/taint.t | 14 +++++++++++++-
3 files changed, 40 insertions(+), 22 deletions(-)
diff --git a/pp_ctl.c b/pp_ctl.c
index 7ff109f..f5a7a48 100644
--- a/pp_ctl.c
+++ b/pp_ctl.c
@@ -240,8 +240,10 @@ PP(pp_regcomp)
#ifndef INCOMPLETE_TAINTS
if (PL_tainting) {
- if (PL_tainted)
+ if (PL_tainted) {
+ SvTAINTED_on((SV*)re);
RX_EXTFLAGS(re) |= RXf_TAINTED;
+ }
else
RX_EXTFLAGS(re) &= ~RXf_TAINTED;
}
diff --git a/pp_hot.c b/pp_hot.c
index 740cfb0..e452f07 100644
--- a/pp_hot.c
+++ b/pp_hot.c
@@ -1235,8 +1235,10 @@ PP(pp_qr)
(void)sv_bless(rv, stash);
}
- if (RX_EXTFLAGS(rx) & RXf_TAINTED)
+ if (RX_EXTFLAGS(rx) & RXf_TAINTED) {
SvTAINTED_on(rv);
+ SvTAINTED_on(SvRV(rv));
+ }
XPUSHs(rv);
RETURN;
}
@@ -2059,18 +2061,19 @@ PP(pp_iter)
/*
A description of how taint works in pattern matching and substitution.
-While the pattern is being assembled and them compiled, PL_tainted will
-get set if any part of the pattern is tainted, e.g. qr/.*$tainted/.
-At the end of pattern compilation, the RXf_TAINTED flag is set on the
-pattern if PL_tainted is set.
+While the pattern is being assembled/concatenated and them compiled,
+PL_tainted will get set if any component of the pattern is tainted, e.g.
+/.*$tainted/. At the end of pattern compilation, the RXf_TAINTED flag
+is set on the pattern if PL_tainted is set.
-When the pattern is copied, e.g. $r = qr/..../, the SV holding the ref the
-pattern is marked as tainted. This means that subsequent usage, such as
-/x$r/, will set PL_tainted and thus RXf_TAINTED on the new pattern too.
+When the pattern is copied, e.g. $r = qr/..../, the SV holding the ref to
+the pattern is marked as tainted. This means that subsequent usage, such
+as /x$r/, will set PL_tainted, and thus RXf_TAINTED, on the new pattern too.
During execution of a pattern, locale-variant ops such as ALNUML set the
local flag RF_tainted. At the end of execution, the engine sets the
-RXf_TAINTED_SEEN on the pattern if RF_tainted got set.
+RXf_TAINTED_SEEN on the pattern if RF_tainted got set, or clears it
+otherwise.
In addition, RXf_TAINTED_SEEN is used post-execution by the get magic code
of $1 et al to indicate whether the returned value should be tainted.
@@ -2115,8 +2118,8 @@ The overall action of pp_subst is:
* Whenever control is being returned to perl code (either by falling
off the "end" of pp_subst/pp_substcont, or by entering a /e block),
use the flag bits in rxtainted to make all the appropriate types of
- destination taint visible; e.g. set RXf_TAINTED_SEEN so that $1 et
- al will appear tainted.
+ destination taint visible; e.g. set RXf_TAINTED_SEEN so that $1
+ et al will appear tainted.
pp_match is just a simpler version of the above.
@@ -2251,6 +2254,15 @@ PP(pp_subst)
matched = CALLREGEXEC(rx, s, strend, orig, 0, TARG, NULL,
r_flags | REXEC_CHECKED);
+
+ if (!matched) {
+ ret_no:
+ SPAGAIN;
+ PUSHs(rpm->op_pmflags & PMf_NONDESTRUCT ? TARG : &PL_sv_no);
+ LEAVE_SCOPE(oldsave);
+ RETURN;
+ }
+
/* known replacement string? */
if (dstr) {
if (SvTAINTED(dstr))
@@ -2260,7 +2272,7 @@ PP(pp_subst)
* but only if it matched; see
*
http://www.nntp.perl.org/group/perl.perl5.porters/2010/04/msg158809.html
*/
- if (matched && DO_UTF8(dstr) && ! DO_UTF8(TARG)) {
+ if (DO_UTF8(dstr) && ! DO_UTF8(TARG)) {
char * const orig_pvx = SvPVX(TARG);
const STRLEN new_len = sv_utf8_upgrade_nomg(TARG);
@@ -2293,14 +2305,6 @@ PP(pp_subst)
doutf8 = FALSE;
}
- if (!matched) {
- ret_no:
- SPAGAIN;
- PUSHs(rpm->op_pmflags & PMf_NONDESTRUCT ? TARG : &PL_sv_no);
- LEAVE_SCOPE(oldsave);
- RETURN;
- }
-
/* can do inplace substitution? */
if (c
#ifdef PERL_OLD_COPY_ON_WRITE
diff --git a/t/op/taint.t b/t/op/taint.t
index dcec7aa..c2ab75d 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 => 684;
+plan tests => 687;
$| = 1;
@@ -2176,6 +2176,18 @@ end
ok( ! tainted($z), "Constants folded value not tainted");
}
+{
+ # now that regexes are first class SVs, make sure that they themselves
+ # as well as references to them are tainted
+
+ my $rr = qr/(.)$TAINT/;
+ my $r = $$rr; # bare REGEX
+ my $s ="abc";
+ ok($s =~ s/$r/x/, "match bare regex");
+ ok(tainted($s), "match bare regex taint");
+ is($s, 'xbc', "match bare regex taint value");
+}
+
# This may bomb out with the alarm signal so keep it last
SKIP: {
skip "No alarm()" unless $Config{d_alarm};
--
Perl5 Master Repository
