+ {
+ # now do them all again with "use re 'taint"
+
+ use re 'taint';
+
+ $desc = "use re 'taint': match with string tainted";
+
+ $s = 'abcd' . $TAINT;
+ $res = $s =~ /(.+)/;
+ $one = $1;
+ is_tainted($s, "$desc: s tainted");
+ isnt_tainted($res, "$desc: res not tainted");
+ is_tainted($one, "$desc: \$1 tainted");
+ is($res, 1, "$desc: res value");
+ is($one, 'abcd', "$desc: \$1 value");
+
+ $desc = "use re 'taint': match /g with string tainted";
+
+ $s = 'abcd' . $TAINT;
+ $res = $s =~ /(.)/g;
+ $one = $1;
+ is_tainted($s, "$desc: s tainted");
+ isnt_tainted($res, "$desc: res not tainted");
+ is_tainted($one, "$desc: \$1 tainted");
+ is($res, 1, "$desc: res value");
+ is($one, 'a', "$desc: \$1 value");
+
+ $desc = "use re 'taint': match with string tainted, list cxt";
+
+ $s = 'abcd' . $TAINT;
+ ($res) = $s =~ /(.+)/;
+ $one = $1;
+ is_tainted($s, "$desc: s tainted");
+ is_tainted($res, "$desc: res tainted");
+ is_tainted($one, "$desc: \$1 tainted");
+ is($res, 'abcd', "$desc: res value");
+ is($one, 'abcd', "$desc: \$1 value");
+
+ $desc = "use re 'taint': match /g with string tainted, list cxt";
+
+ $s = 'abcd' . $TAINT;
+ ($res, $res2) = $s =~ /(.)/g;
+ $one = $1;
+ is_tainted($s, "$desc: s tainted");
+ is_tainted($res, "$desc: res tainted");
+ is_tainted($res2, "$desc: res2 tainted");
+ is_tainted($one, "$desc: \$1 not tainted");
+ is($res, 'a', "$desc: res value");
+ is($res2,'b', "$desc: res2 value");
+ is($one, 'd', "$desc: \$1 value");
+
+ $desc = "use re 'taint': match with pattern tainted";
+
+ $s = 'abcd';
+ $res = $s =~ /$TAINT(.+)/;
+ $one = $1;
+ isnt_tainted($s, "$desc: s not tainted");
+ isnt_tainted($res, "$desc: res not tainted");
+ is_tainted($one, "$desc: \$1 tainted");
+ is($res, 1, "$desc: res value");
+ is($one, 'abcd', "$desc: \$1 value");
+
+ $desc = "use re 'taint': match /g with pattern tainted";
+
+ $s = 'abcd';
+ $res = $s =~ /$TAINT(.)/g;
+ $one = $1;
+ isnt_tainted($s, "$desc: s not tainted");
+ isnt_tainted($res, "$desc: res not tainted");
+ is_tainted($one, "$desc: \$1 tainted");
+ is($res, 1, "$desc: res value");
+ is($one, 'a', "$desc: \$1 value");
+
+ SKIP: {
+ skip 'Locales not available', 10 unless locales_enabled('LC_CTYPE');
+
+ $desc = "use re 'taint': match with pattern tainted via locale";
+
+ $s = 'abcd';
+ {
+ use locale;
+ $res = $s =~ /(\w+)/; $one = $1;
+ }
+ isnt_tainted($s, "$desc: s not tainted");
+ isnt_tainted($res, "$desc: res not tainted");
+ is_tainted($one, "$desc: \$1 tainted");
+ is($res, 1, "$desc: res value");
+ is($one, 'abcd', "$desc: \$1 value");
+
+ $desc = "use re 'taint': match /g with pattern tainted via locale";
+
+ $s = 'abcd';
+ {
+ use locale;
+ $res = $s =~ /(\w)/g; $one = $1;
+ }
+ isnt_tainted($s, "$desc: s not tainted");
+ isnt_tainted($res, "$desc: res not tainted");
+ is_tainted($one, "$desc: \$1 tainted");
+ is($res, 1, "$desc: res value");
+ is($one, 'a', "$desc: \$1 value");
+ }
+
+ $desc = "use re 'taint': match with pattern tainted, list cxt";
+
+ $s = 'abcd';
+ ($res) = $s =~ /$TAINT(.+)/;
+ $one = $1;
+ isnt_tainted($s, "$desc: s not tainted");
+ is_tainted($res, "$desc: res tainted");
+ is_tainted($one, "$desc: \$1 tainted");
+ is($res, 'abcd', "$desc: res value");
+ is($one, 'abcd', "$desc: \$1 value");
+
+ $desc = "use re 'taint': match /g with pattern tainted, list cxt";
+
+ $s = 'abcd';
+ ($res, $res2) = $s =~ /$TAINT(.)/g;
+ $one = $1;
+ isnt_tainted($s, "$desc: s not tainted");
+ is_tainted($res, "$desc: res tainted");
+ is_tainted($one, "$desc: \$1 tainted");
+ is($res, 'a', "$desc: res value");
+ is($res2,'b', "$desc: res2 value");
+ is($one, 'd', "$desc: \$1 value");
+
+ SKIP: {
+ skip 'Locales not available', 12 unless locales_enabled('LC_CTYPE');
+
+ $desc = "use re 'taint': match with pattern tainted via locale, list cxt";
+
+ $s = 'abcd';
+ {
+ use locale;
+ ($res) = $s =~ /(\w+)/; $one = $1;
+ }
+ isnt_tainted($s, "$desc: s not tainted");
+ is_tainted($res, "$desc: res tainted");
+ is_tainted($one, "$desc: \$1 tainted");
+ is($res, 'abcd', "$desc: res value");
+ is($one, 'abcd', "$desc: \$1 value");
+
+ $desc = "use re 'taint': match /g with pattern tainted via locale, list cxt";
+
+ $s = 'abcd';
+ {
+ use locale;
+ ($res, $res2) = $s =~ /(\w)/g; $one = $1;
+ }
+ isnt_tainted($s, "$desc: s not tainted");
+ is_tainted($res, "$desc: res tainted");
+ is_tainted($res2, "$desc: res2 tainted");
+ is_tainted($one, "$desc: \$1 tainted");
+ is($res, 'a', "$desc: res value");
+ is($res2,'b', "$desc: res2 value");
+ is($one, 'd', "$desc: \$1 value");
+ }
+
+ $desc = "use re 'taint': substitution with string tainted";
+
+ $s = 'abcd' . $TAINT;
+ $res = $s =~ s/(.+)/xyz/;
+ $one = $1;
+ is_tainted($s, "$desc: s tainted");
+ isnt_tainted($res, "$desc: res not tainted");
+ is_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 /g with string tainted";
+
+ $s = 'abcd' . $TAINT;
+ $res = $s =~ s/(.)/x/g;
+ $one = $1;
+ is_tainted($s, "$desc: s tainted");
+ is_tainted($res, "$desc: res tainted");
+ is_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 /r with string tainted";
+
+ $s = 'abcd' . $TAINT;
+ $res = $s =~ s/(.+)/xyz/r;
+ $one = $1;
+ is_tainted($s, "$desc: s tainted");
+ is_tainted($res, "$desc: res tainted");
+ is_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
+ isnt_tainted($one, "$desc: code not tainted within /e");
+ $one = $1;
+ is_tainted($one, "$desc: $1 tainted within /e");
+ "xyz";
+ }e;
+ $one = $1;
+ is_tainted($s, "$desc: s tainted");
+ isnt_tainted($res, "$desc: res not tainted");
+ is_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;
+ is_tainted($s, "$desc: s tainted");
+ isnt_tainted($res, "$desc: res not tainted");
+ is_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 /g with pattern tainted";
+
+ $s = 'abcd';
+ $res = $s =~ s/$TAINT(.)/x/g;
+ $one = $1;
+ is_tainted($s, "$desc: s tainted");
+ is_tainted($res, "$desc: res tainted");
+ is_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;
+ isnt_tainted($j, "$desc: code not tainted within /e");
+ $i++;
+ if ($i == 1) {
+ isnt_tainted($s, "$desc: s not tainted loop 1");
+ }
+ else {
+ is_tainted($s, "$desc: s tainted loop $i");
+ }
+ is_tainted($one, "$desc: \$1 tainted loop $i");
+ $i.$TAINT;
+ }ge;
+ $one = $1;
+ }
+ is_tainted($s, "$desc: s tainted");
+ is_tainted($res, "$desc: res tainted");
+ is_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';
+ $res = $s =~ s/$TAINT(.+)/xyz/r;
+ $one = $1;
+ isnt_tainted($s, "$desc: s not tainted");
+ is_tainted($res, "$desc: res tainted");
+ is_tainted($one, "$desc: \$1 tainted");
+ is($s, 'abcd', "$desc: s value");
+ is($res, 'xyz', "$desc: res value");
+ is($one, 'abcd', "$desc: \$1 value");
+
+ SKIP: {
+ skip 'Locales not available', 18 unless locales_enabled('LC_CTYPE');
+
+ $desc = "use re 'taint': substitution with pattern tainted via locale";
+
+ $s = 'abcd';
+ {
+ use locale;
+ $res = $s =~ s/(\w+)/xyz/; $one = $1;
+ }
+ is_tainted($s, "$desc: s tainted");
+ isnt_tainted($res, "$desc: res not tainted");
+ is_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 /g with pattern tainted via locale";
+
+ $s = 'abcd';
+ {
+ use locale;
+ $res = $s =~ s/(\w)/x/g; $one = $1;
+ }
+ is_tainted($s, "$desc: s tainted");
+ is_tainted($res, "$desc: res tainted");
+ is_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 /r with pattern tainted via locale";
+
+ $s = 'abcd';
+ {
+ use locale;
+ $res = $s =~ s/(\w+)/xyz/r; $one = $1;
+ }
+ isnt_tainted($s, "$desc: s not tainted");
+ is_tainted($res, "$desc: res tainted");
+ is_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 with replacement tainted";
+
+ $s = 'abcd';
+ $res = $s =~ s/(.+)/xyz$TAINT/;
+ $one = $1;
+ is_tainted($s, "$desc: s tainted");
+ isnt_tainted($res, "$desc: res not tainted");
+ isnt_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 = "use re 'taint': substitution /g with replacement tainted";
+
+ $s = 'abcd';
+ $res = $s =~ s/(.)/x$TAINT/g;
+ $one = $1;
+ is_tainted($s, "$desc: s tainted");
+ isnt_tainted($res, "$desc: res not tainted");
+ isnt_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;
+ isnt_tainted($j, "$desc: code not tainted within /e");
+ $i++;
+ if ($i == 1) {
+ isnt_tainted($s, "$desc: s not tainted loop 1");
+ }
+ else {
+ is_tainted($s, "$desc: s tainted loop $i");
+ }
+ isnt_tainted($one, "$desc: \$1 not tainted");
+ $i.$TAINT;
+ }ge;
+ $one = $1;
+ }
+ is_tainted($s, "$desc: s tainted");
+ isnt_tainted($res, "$desc: res tainted");
+ isnt_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';
+ $res = $s =~ s/(.+)/xyz$TAINT/r;
+ $one = $1;
+ isnt_tainted($s, "$desc: s not tainted");
+ is_tainted($res, "$desc: res tainted");
+ isnt_tainted($one, "$desc: \$1 not tainted");
+ is($s, 'abcd', "$desc: s value");
+ is($res, 'xyz', "$desc: res value");
+ is($one, 'abcd', "$desc: \$1 value");
+
+ # [perl #121854] match taintedness became sticky
+ # when one match has a taintess result, subseqent matches
+ # using the same pattern shouldn't necessarily be tainted
+
+ {
+ my $f = sub { $_[0] =~ /(.*)/ or die; $1 };
+ $res = $f->($TAINT);
+ is_tainted($res, "121854: res tainted");
+ $res = $f->("abc");
+ isnt_tainted($res, "121854: res not tainted");
+ }