From 20be6587f85cec282e10810718c869dd958afe43 Mon Sep 17 00:00:00 2001 From: David Mitchell Date: Mon, 14 Feb 2011 15:46:13 +0000 Subject: [PATCH] fix many s/// tainting bugs This is a re-implementation of the tainting code in pp_subst and pp_substcont. Although this fixes many bugs, because its a de-novo rewrite of the tainting parts of the code in those two functions, it's quite possible that it breaks some existing tainting behaviour. It doesn't break any existing tests, although it turns out that this area was severely under-tested anyway. The main bugs that this commit fixes are as follows, where: T = a tainted value L = pattern tainted by locale (e.g. use locale; s/\w//) Happens both with and without 'use re taint' unless specified. Happens with all modifiers (/g, /r etc) unless explicitly mentioned. $1 unexpectedly untainted: s/T// T =~ s/// under use re 'taint' original string unexpectedly untainted: s/L//, s/L//g return value unexpectedly untainted: T =~ s///g under no re 'taint' s/L//g, s/L//r return value unexpectedly tainted: s/T// s//T/r under no re 'taint' T =~ s/// under use re 'taint' s//T/ under use re 'taint' Also, with /ge, the original string becomes tainted as soon as possible (usually in the second entry to the /e code block) rather than only at the end, in code like $orig =~ s/T/...code.../ge The rationale behind the taintedness of the return value of s/// (in the non /r case), is that a boolean value shouldn't be tainted. This corresponds to the general perl tainting policy that boolean ops don't return tainted values. On the other hand, when it returns an integer (number of matches), that should be tainted. A couple of note about the old tainting code this replaces: firstly, several occurrences of the following were NOOPs, since rxtainted was U8 and the bit being ored was > 256: rxtainted |= RX_MATCH_TAINTED(rx) secondly, removing a whole bunch of the following didn't make any existing tests fail: TAINT_IF(rxtainted & 1); --- perl.h | 9 +++ pp_ctl.c | 51 +++++++++++-- pp_hot.c | 69 ++++++++++++----- t/op/taint.t | 207 ++++++++++++++++++++++++++++++++++++++++++++------- 4 files changed, 284 insertions(+), 52 deletions(-) diff --git a/perl.h b/perl.h index c7139cde39d4..72d8686587e6 100644 --- a/perl.h +++ b/perl.h @@ -541,6 +541,15 @@ register struct op *Perl_op asm(stringify(OP_IN_REGISTER)); #define TAINT_ENV() if (PL_tainting) { taint_env(); } #define TAINT_PROPER(s) if (PL_tainting) { taint_proper(NULL, s); } +/* flags used internally only within pp_subst and pp_substcont */ +#ifdef PERL_CORE +# define SUBST_TAINT_STR 1 /* string tainted */ +# define SUBST_TAINT_PAT 2 /* pattern tainted */ +# define SUBST_TAINT_REPL 4 /* replacement tainted */ +# define SUBST_TAINT_RETAINT 8 /* use re'taint' in scope */ +# define SUBST_TAINT_BOOLRET 16 /* return is boolean (don't taint) */ +#endif + /* XXX All process group stuff is handled in pp_sys.c. Should these defines move there? If so, I could simplify this a lot. --AD 9/96. */ diff --git a/pp_ctl.c b/pp_ctl.c index 06e3d8f92bbd..ea7a2cd0ec2f 100644 --- a/pp_ctl.c +++ b/pp_ctl.c @@ -294,8 +294,8 @@ PP(pp_substcont) SvGETMAGIC(TOPs); /* possibly clear taint on $1 etc: #67962 */ - if (!(cx->sb_rxtainted & 2) && SvTAINTED(TOPs)) - cx->sb_rxtainted |= 2; + if (SvTAINTED(TOPs)) + cx->sb_rxtainted |= SUBST_TAINT_REPL; sv_catsv_nomg(dstr, POPs); /* XXX: adjust for positive offsets of \G for instance s/(.)\G//g with positive pos() */ s -= RX_GOFS(rx); @@ -317,7 +317,8 @@ PP(pp_substcont) else sv_catpvn(dstr, s, cx->sb_strend - s); } - cx->sb_rxtainted |= RX_MATCH_TAINTED(rx); + if (RX_MATCH_TAINTED(rx)) /* run time pattern taint, eg locale */ + cx->sb_rxtainted |= SUBST_TAINT_PAT; #ifdef PERL_OLD_COPY_ON_WRITE if (SvIsCOW(targ)) { @@ -334,20 +335,38 @@ PP(pp_substcont) SvUTF8_on(targ); SvPV_set(dstr, NULL); - TAINT_IF(cx->sb_rxtainted & 1); if (pm->op_pmflags & PMf_NONDESTRUCT) PUSHs(targ); else mPUSHi(saviters - 1); (void)SvPOK_only_UTF8(targ); - TAINT_IF(cx->sb_rxtainted); - SvSETMAGIC(targ); - SvTAINT(targ); + /* update the taint state of various various variables in + * preparation for final exit */ + if (PL_tainting) { + if ((cx->sb_rxtainted & SUBST_TAINT_PAT) || + ((cx->sb_rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_RETAINT)) + == (SUBST_TAINT_STR|SUBST_TAINT_RETAINT)) + ) + (RX_MATCH_TAINTED_on(rx)); /* taint $1 et al */ + + if (!(cx->sb_rxtainted & SUBST_TAINT_BOOLRET) + && (cx->sb_rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_PAT)) + ) + SvTAINTED_on(TOPs); /* taint return value */ + /* needed for mg_set below */ + PL_tainted = cBOOL(cx->sb_rxtainted & + (SUBST_TAINT_STR|SUBST_TAINT_PAT|SUBST_TAINT_REPL)); + SvTAINT(TARG); + } + /* PL_tainted must be correctly set for this mg_set */ + SvSETMAGIC(TARG); + TAINT_NOT; LEAVE_SCOPE(cx->sb_oldsave); POPSUBST(cx); RETURNOP(pm->op_next); + /* NOTREACHED */ } cx->sb_iters = saviters; } @@ -382,7 +401,23 @@ PP(pp_substcont) } if (old != rx) (void)ReREFCNT_inc(rx); - cx->sb_rxtainted |= RX_MATCH_TAINTED(rx); + /* update the taint state of various various variables in preparation + * for calling the code block */ + if (PL_tainting) { + if (RX_MATCH_TAINTED(rx)) /* run time pattern taint, eg locale */ + cx->sb_rxtainted |= SUBST_TAINT_PAT; + + if ((cx->sb_rxtainted & SUBST_TAINT_PAT) || + ((cx->sb_rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_RETAINT)) + == (SUBST_TAINT_STR|SUBST_TAINT_RETAINT)) + ) + (RX_MATCH_TAINTED_on(rx)); /* taint $1 et al */ + + if (cx->sb_iters > 1 && (cx->sb_rxtainted & + (SUBST_TAINT_STR|SUBST_TAINT_PAT|SUBST_TAINT_REPL))) + SvTAINTED_on(cx->sb_targ); + TAINT_NOT; + } rxres_save(&cx->sb_rxres, rx); PL_curpm = pm; RETURNOP(pm->op_pmstashstartu.op_pmreplstart); diff --git a/pp_hot.c b/pp_hot.c index 7f9a13c7b5bd..0fa5727a5481 100644 --- a/pp_hot.c +++ b/pp_hot.c @@ -2071,7 +2071,7 @@ PP(pp_subst) I32 maxiters; register I32 i; bool once; - U8 rxtainted; + U8 rxtainted = 0; /* holds various SUBST_TAINT_* flag bits */ char *orig; U8 r_flags; register REGEXP *rx = PM_GETRE(pm); @@ -2127,11 +2127,19 @@ PP(pp_subst) s = SvPV_mutable(TARG, len); if (!SvPOKp(TARG) || SvTYPE(TARG) == SVt_PVGV) force_on_match = 1; - rxtainted = ((RX_EXTFLAGS(rx) & RXf_TAINTED) || - (PL_tainted && (pm->op_pmflags & PMf_RETAINT))); - if (PL_tainted) - rxtainted |= 2; - TAINT_NOT; + + /* only replace once? */ + once = !(rpm->op_pmflags & PMf_GLOBAL); + + if (PL_tainting) { + rxtainted = ( + (SvTAINTED(TARG) ? SUBST_TAINT_STR : 0) + | ((RX_EXTFLAGS(rx) & RXf_TAINTED) ? SUBST_TAINT_PAT : 0) + | ((pm->op_pmflags & PMf_RETAINT) ? SUBST_TAINT_RETAINT : 0) + | ((once && !(rpm->op_pmflags & PMf_NONDESTRUCT)) + ? SUBST_TAINT_BOOLRET : 0)); + TAINT_NOT; + } RX_MATCH_UTF8_set(rx, DO_UTF8(TARG)); @@ -2173,12 +2181,12 @@ PP(pp_subst) */ } - /* only replace once? */ - once = !(rpm->op_pmflags & PMf_GLOBAL); matched = CALLREGEXEC(rx, s, strend, orig, 0, TARG, NULL, r_flags | REXEC_CHECKED); /* known replacement string? */ if (dstr) { + if (SvTAINTED(dstr)) + rxtainted |= SUBST_TAINT_REPL; /* Upgrade the source if the replacement is utf8 but the source is not, * but only if it matched; see @@ -2250,7 +2258,8 @@ PP(pp_subst) PL_curpm = pm; SvSCREAM_off(TARG); /* disable possible screamer */ if (once) { - rxtainted |= RX_MATCH_TAINTED(rx); + if (RX_MATCH_TAINTED(rx)) /* run time pattern taint, eg locale */ + rxtainted |= SUBST_TAINT_PAT; m = orig + RX_OFFS(rx)[0].start; d = orig + RX_OFFS(rx)[0].end; s = orig; @@ -2283,7 +2292,6 @@ PP(pp_subst) else { sv_chop(TARG, d); } - TAINT_IF(rxtainted & 1); SPAGAIN; PUSHs(rpm->op_pmflags & PMf_NONDESTRUCT ? TARG : &PL_sv_yes); } @@ -2291,7 +2299,8 @@ PP(pp_subst) do { if (iters++ > maxiters) DIE(aTHX_ "Substitution loop"); - rxtainted |= RX_MATCH_TAINTED(rx); + if (RX_MATCH_TAINTED(rx)) /* run time pattern taint, eg locale */ + rxtainted |= SUBST_TAINT_PAT; m = RX_OFFS(rx)[0].start + orig; if ((i = m - s)) { if (s != d) @@ -2312,7 +2321,6 @@ PP(pp_subst) SvCUR_set(TARG, d - SvPVX_const(TARG) + i); Move(s, d, i+1, char); /* include the NUL */ } - TAINT_IF(rxtainted & 1); SPAGAIN; if (rpm->op_pmflags & PMf_NONDESTRUCT) PUSHs(TARG); @@ -2329,13 +2337,19 @@ PP(pp_subst) #ifdef PERL_OLD_COPY_ON_WRITE have_a_cow: #endif - rxtainted |= RX_MATCH_TAINTED(rx); + if (RX_MATCH_TAINTED(rx)) /* run time pattern taint, eg locale */ + rxtainted |= SUBST_TAINT_PAT; dstr = newSVpvn_utf8(m, s-m, DO_UTF8(TARG)); SAVEFREESV(dstr); PL_curpm = pm; if (!c) { register PERL_CONTEXT *cx; SPAGAIN; + /* note that a whole bunch of local vars are saved here for + * use by pp_substcont: here's a list of them in case you're + * searching for places in this sub that uses a particular var: + * iters maxiters r_flags oldsave rxtainted orig dstr targ + * s m strend rx once */ PUSHSUBST(cx); RETURNOP(cPMOP->op_pmreplrootu.op_pmreplroot); } @@ -2343,7 +2357,8 @@ PP(pp_subst) do { if (iters++ > maxiters) DIE(aTHX_ "Substitution loop"); - rxtainted |= RX_MATCH_TAINTED(rx); + if (RX_MATCH_TAINTED(rx)) + rxtainted |= SUBST_TAINT_PAT; if (RX_MATCH_COPIED(rx) && RX_SUBBEG(rx) != orig) { m = s; s = orig; @@ -2387,7 +2402,6 @@ PP(pp_subst) doutf8 |= DO_UTF8(dstr); SvPV_set(dstr, NULL); - TAINT_IF(rxtainted & 1); SPAGAIN; if (rpm->op_pmflags & PMf_NONDESTRUCT) PUSHs(TARG); @@ -2397,9 +2411,28 @@ PP(pp_subst) (void)SvPOK_only_UTF8(TARG); if (doutf8) SvUTF8_on(TARG); - TAINT_IF(rxtainted); - SvSETMAGIC(TARG); - SvTAINT(TARG); + + if (PL_tainting) { + if ((rxtainted & SUBST_TAINT_PAT) || + ((rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_RETAINT)) == + (SUBST_TAINT_STR|SUBST_TAINT_RETAINT)) + ) + (RX_MATCH_TAINTED_on(rx)); /* taint $1 et al */ + + if (!(rxtainted & SUBST_TAINT_BOOLRET) + && (rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_PAT)) + ) + SvTAINTED_on(TOPs); /* taint return value */ + else + SvTAINTED_off(TOPs); /* may have got tainted earlier */ + + /* needed for mg_set below */ + PL_tainted = + cBOOL(rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_PAT|SUBST_TAINT_REPL)); + SvTAINT(TARG); + } + SvSETMAGIC(TARG); /* PL_tainted must be correctly set for this mg_set */ + TAINT_NOT; LEAVE_SCOPE(oldsave); RETURN; } diff --git a/t/op/taint.t b/t/op/taint.t index ddef4b97ef13..dcec7aa9e2b8 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 => 608; +plan tests => 684; $| = 1; @@ -407,7 +407,7 @@ my $TEST = catfile(curdir(), 'TEST'); $res = $s =~ s/(.)/x/g; $one = $1; ok( tainted($s), "$desc: s tainted"); - { local $::TODO = "todo"; ok( tainted($res), "$desc: res tainted"); } + ok( tainted($res), "$desc: res tainted"); ok(!tainted($one), "$desc: \$1 not tainted"); is($s, 'xxxx', "$desc: s value"); is($res, 4, "$desc: res value"); @@ -425,14 +425,33 @@ my $TEST = catfile(curdir(), 'TEST'); is($res, 'xyz', "$desc: res value"); is($one, 'abcd', "$desc: \$1 value"); + $desc = "substitution /e with string tainted"; + + $s = 'abcd' . $TAINT; + $one = ''; + $res = $s =~ s{(.+)}{ + $one = $one . "x"; # make sure code not tainted + ok(!tainted($one), "$desc: code not tainted within /e"); + $one = $1; + ok(!tainted($one), "$desc: \$1 not tainted within /e"); + "xyz"; + }e; + $one = $1; + ok( tainted($s), "$desc: s tainted"); + ok(!tainted($res), "$desc: res not tainted"); + ok(!tainted($one), "$desc: \$1 not tainted"); + is($s, 'xyz', "$desc: s value"); + is($res, 1, "$desc: res value"); + is($one, 'abcd', "$desc: \$1 value"); + $desc = "substitution with pattern tainted"; $s = 'abcd'; $res = $s =~ s/$TAINT(.+)/xyz/; $one = $1; ok( tainted($s), "$desc: s tainted"); - { local $::TODO = "todo"; ok(!tainted($res), "$desc: res not tainted"); } - { local $::TODO = "todo"; ok( tainted($one), "$desc: \$1 tainted"); } + ok(!tainted($res), "$desc: res not tainted"); + ok( tainted($one), "$desc: \$1 tainted"); is($s, 'xyz', "$desc: s value"); is($res, 1, "$desc: res value"); is($one, 'abcd', "$desc: \$1 value"); @@ -444,11 +463,40 @@ my $TEST = catfile(curdir(), 'TEST'); $one = $1; ok( tainted($s), "$desc: s tainted"); ok( tainted($res), "$desc: res tainted"); - { local $::TODO = "todo"; ok( tainted($one), "$desc: \$1 tainted"); } + ok( tainted($one), "$desc: \$1 tainted"); is($s, 'xxxx', "$desc: s value"); is($res, 4, "$desc: res value"); is($one, 'd', "$desc: \$1 value"); + $desc = "substitution /ge with pattern tainted"; + + $s = 'abc'; + { + my $i = 0; + my $j; + $res = $s =~ s{(.)$TAINT}{ + $j = $i; # make sure code not tainted + $one = $1; + ok(!tainted($j), "$desc: code not tainted within /e"); + $i++; + if ($i == 1) { + ok(!tainted($s), "$desc: s not tainted loop 1"); + } + else { + ok( tainted($s), "$desc: s tainted loop $i"); + } + ok( tainted($one), "$desc: \$1 tainted loop $i"); + $i.$TAINT; + }ge; + $one = $1; + } + ok( tainted($s), "$desc: s tainted"); + ok( tainted($res), "$desc: res tainted"); + ok( tainted($one), "$desc: \$1 tainted"); + is($s, '123', "$desc: s value"); + is($res, 3, "$desc: res value"); + is($one, 'c', "$desc: \$1 value"); + $desc = "substitution /r with pattern tainted"; $s = 'abcd'; @@ -456,7 +504,7 @@ my $TEST = catfile(curdir(), 'TEST'); $one = $1; ok(!tainted($s), "$desc: s not tainted"); ok( tainted($res), "$desc: res tainted"); - { local $::TODO = "todo"; ok( tainted($one), "$desc: \$1 tainted"); } + ok( tainted($one), "$desc: \$1 tainted"); is($s, 'abcd', "$desc: s value"); is($res, 'xyz', "$desc: res value"); is($one, 'abcd', "$desc: \$1 value"); @@ -465,7 +513,7 @@ my $TEST = catfile(curdir(), 'TEST'); $s = 'abcd'; { use locale; $res = $s =~ s/(\w+)/xyz/; $one = $1; } - { local $::TODO = "todo"; ok( tainted($s), "$desc: s tainted"); } + ok( tainted($s), "$desc: s tainted"); ok(!tainted($res), "$desc: res not tainted"); ok( tainted($one), "$desc: \$1 tainted"); is($s, 'xyz', "$desc: s value"); @@ -476,8 +524,8 @@ my $TEST = catfile(curdir(), 'TEST'); $s = 'abcd'; { use locale; $res = $s =~ s/(\w)/x/g; $one = $1; } - { local $::TODO = "todo"; ok( tainted($s), "$desc: s tainted"); } - { local $::TODO = "todo"; ok( tainted($res), "$desc: res tainted"); } + ok( tainted($s), "$desc: s tainted"); + ok( tainted($res), "$desc: res tainted"); ok( tainted($one), "$desc: \$1 tainted"); is($s, 'xxxx', "$desc: s value"); is($res, 4, "$desc: res value"); @@ -488,7 +536,7 @@ my $TEST = catfile(curdir(), 'TEST'); $s = 'abcd'; { use locale; $res = $s =~ s/(\w+)/xyz/r; $one = $1; } ok(!tainted($s), "$desc: s not tainted"); - { local $::TODO = "todo"; ok( tainted($res), "$desc: res tainted"); } + ok( tainted($res), "$desc: res tainted"); ok( tainted($one), "$desc: \$1 tainted"); is($s, 'abcd', "$desc: s value"); is($res, 'xyz', "$desc: res value"); @@ -500,7 +548,7 @@ my $TEST = catfile(curdir(), 'TEST'); $res = $s =~ s/(.+)/xyz$TAINT/; $one = $1; ok( tainted($s), "$desc: s tainted"); - { local $::TODO = "todo"; ok(!tainted($res), "$desc: res not tainted"); } + ok(!tainted($res), "$desc: res not tainted"); ok(!tainted($one), "$desc: \$1 not tainted"); is($s, 'xyz', "$desc: s value"); is($res, 1, "$desc: res value"); @@ -512,12 +560,41 @@ my $TEST = catfile(curdir(), 'TEST'); $res = $s =~ s/(.)/x$TAINT/g; $one = $1; ok( tainted($s), "$desc: s tainted"); - { local $::TODO = "todo"; ok(!tainted($res), "$desc: res not tainted"); } + ok(!tainted($res), "$desc: res not tainted"); ok(!tainted($one), "$desc: \$1 not tainted"); is($s, 'xxxx', "$desc: s value"); is($res, 4, "$desc: res value"); is($one, 'd', "$desc: \$1 value"); + $desc = "substitution /ge with replacement tainted"; + + $s = 'abc'; + { + my $i = 0; + my $j; + $res = $s =~ s{(.)}{ + $j = $i; # make sure code not tainted + $one = $1; + ok(!tainted($j), "$desc: code not tainted within /e"); + $i++; + if ($i == 1) { + ok(!tainted($s), "$desc: s not tainted loop 1"); + } + else { + ok( tainted($s), "$desc: s tainted loop $i"); + } + ok(!tainted($one), "$desc: \$1 not tainted within /e"); + $i.$TAINT; + }ge; + $one = $1; + } + ok( tainted($s), "$desc: s tainted"); + ok( tainted($res), "$desc: res tainted"); + ok(!tainted($one), "$desc: \$1 not tainted"); + is($s, '123', "$desc: s value"); + is($res, 3, "$desc: res value"); + is($one, 'c', "$desc: \$1 value"); + $desc = "substitution /r with replacement tainted"; $s = 'abcd'; @@ -674,8 +751,8 @@ my $TEST = catfile(curdir(), 'TEST'); $res = $s =~ s/(.+)/xyz/; $one = $1; ok( tainted($s), "$desc: s tainted"); - { local $::TODO = "todo"; ok(!tainted($res), "$desc: res not tainted"); } - { local $::TODO = "todo"; ok( tainted($one), "$desc: \$1 tainted"); } + ok(!tainted($res), "$desc: res not tainted"); + ok( tainted($one), "$desc: \$1 tainted"); is($s, 'xyz', "$desc: s value"); is($res, 1, "$desc: res value"); is($one, 'abcd', "$desc: \$1 value"); @@ -687,7 +764,7 @@ my $TEST = catfile(curdir(), 'TEST'); $one = $1; ok( tainted($s), "$desc: s tainted"); ok( tainted($res), "$desc: res tainted"); - { local $::TODO = "todo"; ok( tainted($one), "$desc: \$1 tainted"); } + ok( tainted($one), "$desc: \$1 tainted"); is($s, 'xxxx', "$desc: s value"); is($res, 4, "$desc: res value"); is($one, 'd', "$desc: \$1 value"); @@ -699,19 +776,38 @@ my $TEST = catfile(curdir(), 'TEST'); $one = $1; ok( tainted($s), "$desc: s tainted"); ok( tainted($res), "$desc: res tainted"); - { local $::TODO = "todo"; ok( tainted($one), "$desc: \$1 tainted"); } + ok( tainted($one), "$desc: \$1 tainted"); is($s, 'abcd', "$desc: s value"); is($res, 'xyz', "$desc: res value"); is($one, 'abcd', "$desc: \$1 value"); + $desc = "use re 'taint': substitution /e with string tainted"; + + $s = 'abcd' . $TAINT; + $one = ''; + $res = $s =~ s{(.+)}{ + $one = $one . "x"; # make sure code not tainted + ok(!tainted($one), "$desc: code not tainted within /e"); + $one = $1; + ok(tainted($one), "$desc: $1 tainted within /e"); + "xyz"; + }e; + $one = $1; + ok( tainted($s), "$desc: s tainted"); + ok(!tainted($res), "$desc: res not tainted"); + ok( tainted($one), "$desc: \$1 tainted"); + is($s, 'xyz', "$desc: s value"); + is($res, 1, "$desc: res value"); + is($one, 'abcd', "$desc: \$1 value"); + $desc = "use re 'taint': substitution with pattern tainted"; $s = 'abcd'; $res = $s =~ s/$TAINT(.+)/xyz/; $one = $1; ok( tainted($s), "$desc: s tainted"); - { local $::TODO = "todo"; ok(!tainted($res), "$desc: res not tainted"); } - { local $::TODO = "todo"; ok( tainted($one), "$desc: \$1 tainted"); } + ok(!tainted($res), "$desc: res not tainted"); + ok( tainted($one), "$desc: \$1 tainted"); is($s, 'xyz', "$desc: s value"); is($res, 1, "$desc: res value"); is($one, 'abcd', "$desc: \$1 value"); @@ -723,11 +819,41 @@ my $TEST = catfile(curdir(), 'TEST'); $one = $1; ok( tainted($s), "$desc: s tainted"); ok( tainted($res), "$desc: res tainted"); - { local $::TODO = "todo"; ok( tainted($one), "$desc: \$1 tainted"); } + ok( tainted($one), "$desc: \$1 tainted"); is($s, 'xxxx', "$desc: s value"); is($res, 4, "$desc: res value"); is($one, 'd', "$desc: \$1 value"); + $desc = "use re 'taint': substitution /ge with pattern tainted"; + + $s = 'abc'; + { + my $i = 0; + my $j; + $res = $s =~ s{(.)$TAINT}{ + $j = $i; # make sure code not tainted + $one = $1; + ok(!tainted($j), "$desc: code not tainted within /e"); + $i++; + if ($i == 1) { + ok(!tainted($s), "$desc: s not tainted loop 1"); + } + else { + ok( tainted($s), "$desc: s tainted loop $i"); + } + ok( tainted($one), "$desc: \$1 tainted loop $i"); + $i.$TAINT; + }ge; + $one = $1; + } + ok( tainted($s), "$desc: s tainted"); + ok( tainted($res), "$desc: res tainted"); + ok( tainted($one), "$desc: \$1 tainted"); + is($s, '123', "$desc: s value"); + is($res, 3, "$desc: res value"); + is($one, 'c', "$desc: \$1 value"); + + $desc = "use re 'taint': substitution /r with pattern tainted"; $s = 'abcd'; @@ -735,7 +861,7 @@ my $TEST = catfile(curdir(), 'TEST'); $one = $1; ok(!tainted($s), "$desc: s not tainted"); ok( tainted($res), "$desc: res tainted"); - { local $::TODO = "todo"; ok( tainted($one), "$desc: \$1 tainted"); } + ok( tainted($one), "$desc: \$1 tainted"); is($s, 'abcd', "$desc: s value"); is($res, 'xyz', "$desc: res value"); is($one, 'abcd', "$desc: \$1 value"); @@ -744,7 +870,7 @@ my $TEST = catfile(curdir(), 'TEST'); $s = 'abcd'; { use locale; $res = $s =~ s/(\w+)/xyz/; $one = $1; } - { local $::TODO = "todo"; ok( tainted($s), "$desc: s tainted"); } + ok( tainted($s), "$desc: s tainted"); ok(!tainted($res), "$desc: res not tainted"); ok( tainted($one), "$desc: \$1 tainted"); is($s, 'xyz', "$desc: s value"); @@ -755,8 +881,8 @@ my $TEST = catfile(curdir(), 'TEST'); $s = 'abcd'; { use locale; $res = $s =~ s/(\w)/x/g; $one = $1; } - { local $::TODO = "todo"; ok( tainted($s), "$desc: s tainted"); } - { local $::TODO = "todo"; ok( tainted($res), "$desc: res tainted"); } + ok( tainted($s), "$desc: s tainted"); + ok( tainted($res), "$desc: res tainted"); ok( tainted($one), "$desc: \$1 tainted"); is($s, 'xxxx', "$desc: s value"); is($res, 4, "$desc: res value"); @@ -767,7 +893,7 @@ my $TEST = catfile(curdir(), 'TEST'); $s = 'abcd'; { use locale; $res = $s =~ s/(\w+)/xyz/r; $one = $1; } ok(!tainted($s), "$desc: s not tainted"); - { local $::TODO = "todo"; ok( tainted($res), "$desc: res tainted"); } + ok( tainted($res), "$desc: res tainted"); ok( tainted($one), "$desc: \$1 tainted"); is($s, 'abcd', "$desc: s value"); is($res, 'xyz', "$desc: res value"); @@ -779,7 +905,7 @@ my $TEST = catfile(curdir(), 'TEST'); $res = $s =~ s/(.+)/xyz$TAINT/; $one = $1; ok( tainted($s), "$desc: s tainted"); - { local $::TODO = "todo"; ok(!tainted($res), "$desc: res not tainted"); } + ok(!tainted($res), "$desc: res not tainted"); ok(!tainted($one), "$desc: \$1 not tainted"); is($s, 'xyz', "$desc: s value"); is($res, 1, "$desc: res value"); @@ -791,12 +917,41 @@ my $TEST = catfile(curdir(), 'TEST'); $res = $s =~ s/(.)/x$TAINT/g; $one = $1; ok( tainted($s), "$desc: s tainted"); - { local $::TODO = "todo"; ok(!tainted($res), "$desc: res not tainted"); } + ok(!tainted($res), "$desc: res not tainted"); ok(!tainted($one), "$desc: \$1 not tainted"); is($s, 'xxxx', "$desc: s value"); is($res, 4, "$desc: res value"); is($one, 'd', "$desc: \$1 value"); + $desc = "use re 'taint': substitution /ge with replacement tainted"; + + $s = 'abc'; + { + my $i = 0; + my $j; + $res = $s =~ s{(.)}{ + $j = $i; # make sure code not tainted + $one = $1; + ok(!tainted($j), "$desc: code not tainted within /e"); + $i++; + if ($i == 1) { + ok(!tainted($s), "$desc: s not tainted loop 1"); + } + else { + ok( tainted($s), "$desc: s tainted loop $i"); + } + ok(!tainted($one), "$desc: \$1 not tainted"); + $i.$TAINT; + }ge; + $one = $1; + } + ok( tainted($s), "$desc: s tainted"); + ok( tainted($res), "$desc: res tainted"); + ok(!tainted($one), "$desc: \$1 not tainted"); + is($s, '123', "$desc: s value"); + is($res, 3, "$desc: res value"); + is($one, 'c', "$desc: \$1 value"); + $desc = "use re 'taint': substitution /r with replacement tainted"; $s = 'abcd';