2 # tests whether tainting works with UTF-8
5 if ($ENV{PERL_CORE_MINITEST}) {
6 print "1..0 # Skip: no dynamic loading on miniperl, no threads\n";
17 if ($Config{extensions} !~ m(\bList/Util\b)) {
18 print "1..0 # Skip: no Scalar::Util module\n";
23 use Scalar::Util qw(tainted);
26 plan tests => 3*10 + 3*8 + 2*16;
29 my $arg = $ENV{PATH}; # a tainted value
30 use constant UTF8 => "\x{1234}";
34 return 0xB6 != unpack('C', chr(0xB6).$s);
37 for my $ary ([ascii => 'perl'], [latin1 => "\xB6"], [utf8 => "\x{100}"]) {
38 my $encode = $ary->[0];
39 my $string = $ary->[1];
41 my $taint = $arg; substr($taint, 0) = $ary->[1];
43 print tainted($taint) == tainted($arg)
44 ? "ok " : "not ok ", ++$cnt, " # tainted: $encode, before test\n";
48 print $lconcat eq $string.UTF8
49 ? "ok " : "not ok ", ++$cnt, " # compare: $encode, concat left\n";
51 print tainted($lconcat) == tainted($arg)
52 ? "ok " : "not ok ", ++$cnt, " # tainted: $encode, concat left\n";
56 print $rconcat eq UTF8.$string
57 ? "ok " : "not ok ", ++$cnt, " # compare: $encode, concat right\n";
59 print tainted($rconcat) == tainted($arg)
60 ? "ok " : "not ok ", ++$cnt, " # tainted: $encode, concat right\n";
62 my $ljoin = join('!', $taint, UTF8);
63 print $ljoin eq join('!', $string, UTF8)
64 ? "ok " : "not ok ", ++$cnt, " # compare: $encode, join left\n";
66 print tainted($ljoin) == tainted($arg)
67 ? "ok " : "not ok ", ++$cnt, " # tainted: $encode, join left\n";
69 my $rjoin = join('!', UTF8, $taint);
70 print $rjoin eq join('!', UTF8, $string)
71 ? "ok " : "not ok ", ++$cnt, " # compare: $encode, join right\n";
73 print tainted($rjoin) == tainted($arg)
74 ? "ok " : "not ok ", ++$cnt, " # tainted: $encode, join right\n";
76 print tainted($taint) == tainted($arg)
77 ? "ok " : "not ok ", ++$cnt, " # tainted: $encode, after test\n";
81 for my $ary ([ascii => 'perl'], [latin1 => "\xB6"], [utf8 => "\x{100}"]) {
82 my $encode = $ary->[0];
84 my $utf8 = pack('U*') . $ary->[1];
85 my $byte = unpack('U0a*', $utf8);
87 my $taint = $arg; substr($taint, 0) = $utf8;
91 ? "ok " : "not ok ", ++$cnt, " # compare: $encode, encode utf8\n";
93 print pack('a*',$taint) eq pack('a*',$byte)
94 ? "ok " : "not ok ", ++$cnt, " # bytecmp: $encode, encode utf8\n";
96 print !is_utf8($taint)
97 ? "ok " : "not ok ", ++$cnt, " # is_utf8: $encode, encode utf8\n";
99 print tainted($taint) == tainted($arg)
100 ? "ok " : "not ok ", ++$cnt, " # tainted: $encode, encode utf8\n";
102 my $taint = $arg; substr($taint, 0) = $byte;
103 utf8::decode($taint);
105 print $taint eq $utf8
106 ? "ok " : "not ok ", ++$cnt, " # compare: $encode, decode byte\n";
108 print pack('a*',$taint) eq pack('a*',$utf8)
109 ? "ok " : "not ok ", ++$cnt, " # bytecmp: $encode, decode byte\n";
111 print is_utf8($taint) eq ($encode ne 'ascii')
112 ? "ok " : "not ok ", ++$cnt, " # is_utf8: $encode, decode byte\n";
114 print tainted($taint) == tainted($arg)
115 ? "ok " : "not ok ", ++$cnt, " # tainted: $encode, decode byte\n";
119 for my $ary ([ascii => 'perl'], [latin1 => "\xB6"]) {
120 my $encode = $ary->[0];
122 my $up = pack('U*') . $ary->[1];
123 my $down = pack("a*", $ary->[1]);
125 my $taint = $arg; substr($taint, 0) = $up;
126 utf8::upgrade($taint);
129 ? "ok " : "not ok ", ++$cnt, " # compare: $encode, upgrade up\n";
131 print pack('a*',$taint) eq pack('a*',$up)
132 ? "ok " : "not ok ", ++$cnt, " # bytecmp: $encode, upgrade up\n";
134 print is_utf8($taint)
135 ? "ok " : "not ok ", ++$cnt, " # is_utf8: $encode, upgrade up\n";
137 print tainted($taint) == tainted($arg)
138 ? "ok " : "not ok ", ++$cnt, " # tainted: $encode, upgrade up\n";
140 my $taint = $arg; substr($taint, 0) = $down;
141 utf8::upgrade($taint);
144 ? "ok " : "not ok ", ++$cnt, " # compare: $encode, upgrade down\n";
146 print pack('a*',$taint) eq pack('a*',$up)
147 ? "ok " : "not ok ", ++$cnt, " # bytecmp: $encode, upgrade down\n";
149 print is_utf8($taint)
150 ? "ok " : "not ok ", ++$cnt, " # is_utf8: $encode, upgrade down\n";
152 print tainted($taint) == tainted($arg)
153 ? "ok " : "not ok ", ++$cnt, " # tainted: $encode, upgrade down\n";
155 my $taint = $arg; substr($taint, 0) = $up;
156 utf8::downgrade($taint);
158 print $taint eq $down
159 ? "ok " : "not ok ", ++$cnt, " # compare: $encode, downgrade up\n";
161 print pack('a*',$taint) eq pack('a*',$down)
162 ? "ok " : "not ok ", ++$cnt, " # bytecmp: $encode, downgrade up\n";
164 print !is_utf8($taint)
165 ? "ok " : "not ok ", ++$cnt, " # is_utf8: $encode, downgrade up\n";
167 print tainted($taint) == tainted($arg)
168 ? "ok " : "not ok ", ++$cnt, " # tainted: $encode, downgrade up\n";
170 my $taint = $arg; substr($taint, 0) = $down;
171 utf8::downgrade($taint);
173 print $taint eq $down
174 ? "ok " : "not ok ", ++$cnt, " # compare: $encode, downgrade down\n";
176 print pack('a*',$taint) eq pack('a*',$down)
177 ? "ok " : "not ok ", ++$cnt, " # bytecmp: $encode, downgrade down\n";
179 print !is_utf8($taint)
180 ? "ok " : "not ok ", ++$cnt, " # is_utf8: $encode, downgrade down\n";
182 print tainted($taint) == tainted($arg)
183 ? "ok " : "not ok ", ++$cnt, " # tainted: $encode, downgrade down\n";