Commit | Line | Data |
d0ea2801 |
1 | #!./perl -T |
2 | # tests whether tainting works with UTF-8 |
3 | |
4 | BEGIN { |
5 | if ($ENV{PERL_CORE_MINITEST}) { |
6 | print "1..0 # Skip: no dynamic loading on miniperl, no threads\n"; |
7 | exit 0; |
8 | } |
9 | chdir 't' if -d 't'; |
10 | @INC = qw(../lib); |
11 | } |
12 | |
13 | use strict; |
14 | use Config; |
15 | |
16 | BEGIN { |
17 | if ($Config{extensions} !~ m(\bList/Util\b)) { |
18 | print "1..0 # Skip: no Scalar::Util module\n"; |
19 | exit 0; |
20 | } |
21 | } |
22 | |
23 | use Scalar::Util qw(tainted); |
24 | |
25 | use Test; |
78ea37eb |
26 | plan tests => 3*10 + 3*8 + 2*16; |
d0ea2801 |
27 | my $cnt = 0; |
28 | |
29 | my $arg = $ENV{PATH}; # a tainted value |
30 | use constant UTF8 => "\x{1234}"; |
31 | |
78ea37eb |
32 | sub is_utf8 { |
33 | my $s = shift; |
f337b084 |
34 | return 0xB6 != unpack('C', chr(0xB6).$s); |
78ea37eb |
35 | } |
36 | |
d0ea2801 |
37 | for my $ary ([ascii => 'perl'], [latin1 => "\xB6"], [utf8 => "\x{100}"]) { |
38 | my $encode = $ary->[0]; |
39 | my $string = $ary->[1]; |
40 | |
41 | my $taint = $arg; substr($taint, 0) = $ary->[1]; |
42 | |
43 | print tainted($taint) == tainted($arg) |
44 | ? "ok " : "not ok ", ++$cnt, " # tainted: $encode, before test\n"; |
45 | |
46 | my $lconcat = $taint; |
47 | $lconcat .= UTF8; |
78ea37eb |
48 | print $lconcat eq $string.UTF8 |
d0ea2801 |
49 | ? "ok " : "not ok ", ++$cnt, " # compare: $encode, concat left\n"; |
50 | |
51 | print tainted($lconcat) == tainted($arg) |
52 | ? "ok " : "not ok ", ++$cnt, " # tainted: $encode, concat left\n"; |
53 | |
54 | my $rconcat = UTF8; |
55 | $rconcat .= $taint; |
78ea37eb |
56 | print $rconcat eq UTF8.$string |
d0ea2801 |
57 | ? "ok " : "not ok ", ++$cnt, " # compare: $encode, concat right\n"; |
58 | |
59 | print tainted($rconcat) == tainted($arg) |
60 | ? "ok " : "not ok ", ++$cnt, " # tainted: $encode, concat right\n"; |
61 | |
62 | my $ljoin = join('!', $taint, UTF8); |
63 | print $ljoin eq join('!', $string, UTF8) |
64 | ? "ok " : "not ok ", ++$cnt, " # compare: $encode, join left\n"; |
65 | |
66 | print tainted($ljoin) == tainted($arg) |
67 | ? "ok " : "not ok ", ++$cnt, " # tainted: $encode, join left\n"; |
68 | |
69 | my $rjoin = join('!', UTF8, $taint); |
70 | print $rjoin eq join('!', UTF8, $string) |
71 | ? "ok " : "not ok ", ++$cnt, " # compare: $encode, join right\n"; |
72 | |
73 | print tainted($rjoin) == tainted($arg) |
74 | ? "ok " : "not ok ", ++$cnt, " # tainted: $encode, join right\n"; |
75 | |
76 | print tainted($taint) == tainted($arg) |
77 | ? "ok " : "not ok ", ++$cnt, " # tainted: $encode, after test\n"; |
78 | } |
78ea37eb |
79 | |
80 | |
81 | for my $ary ([ascii => 'perl'], [latin1 => "\xB6"], [utf8 => "\x{100}"]) { |
82 | my $encode = $ary->[0]; |
83 | |
84 | my $utf8 = pack('U*') . $ary->[1]; |
f337b084 |
85 | my $byte = unpack('U0a*', $utf8); |
78ea37eb |
86 | |
87 | my $taint = $arg; substr($taint, 0) = $utf8; |
88 | utf8::encode($taint); |
89 | |
90 | print $taint eq $byte |
91 | ? "ok " : "not ok ", ++$cnt, " # compare: $encode, encode utf8\n"; |
92 | |
93 | print pack('a*',$taint) eq pack('a*',$byte) |
94 | ? "ok " : "not ok ", ++$cnt, " # bytecmp: $encode, encode utf8\n"; |
95 | |
96 | print !is_utf8($taint) |
97 | ? "ok " : "not ok ", ++$cnt, " # is_utf8: $encode, encode utf8\n"; |
98 | |
99 | print tainted($taint) == tainted($arg) |
100 | ? "ok " : "not ok ", ++$cnt, " # tainted: $encode, encode utf8\n"; |
101 | |
102 | my $taint = $arg; substr($taint, 0) = $byte; |
103 | utf8::decode($taint); |
104 | |
105 | print $taint eq $utf8 |
106 | ? "ok " : "not ok ", ++$cnt, " # compare: $encode, decode byte\n"; |
107 | |
108 | print pack('a*',$taint) eq pack('a*',$utf8) |
109 | ? "ok " : "not ok ", ++$cnt, " # bytecmp: $encode, decode byte\n"; |
110 | |
111 | print is_utf8($taint) eq ($encode ne 'ascii') |
112 | ? "ok " : "not ok ", ++$cnt, " # is_utf8: $encode, decode byte\n"; |
113 | |
114 | print tainted($taint) == tainted($arg) |
115 | ? "ok " : "not ok ", ++$cnt, " # tainted: $encode, decode byte\n"; |
116 | } |
117 | |
118 | |
119 | for my $ary ([ascii => 'perl'], [latin1 => "\xB6"]) { |
120 | my $encode = $ary->[0]; |
121 | |
122 | my $up = pack('U*') . $ary->[1]; |
f337b084 |
123 | my $down = pack("a*", $ary->[1]); |
78ea37eb |
124 | |
125 | my $taint = $arg; substr($taint, 0) = $up; |
126 | utf8::upgrade($taint); |
127 | |
128 | print $taint eq $up |
129 | ? "ok " : "not ok ", ++$cnt, " # compare: $encode, upgrade up\n"; |
130 | |
131 | print pack('a*',$taint) eq pack('a*',$up) |
132 | ? "ok " : "not ok ", ++$cnt, " # bytecmp: $encode, upgrade up\n"; |
133 | |
134 | print is_utf8($taint) |
135 | ? "ok " : "not ok ", ++$cnt, " # is_utf8: $encode, upgrade up\n"; |
136 | |
137 | print tainted($taint) == tainted($arg) |
138 | ? "ok " : "not ok ", ++$cnt, " # tainted: $encode, upgrade up\n"; |
139 | |
140 | my $taint = $arg; substr($taint, 0) = $down; |
141 | utf8::upgrade($taint); |
142 | |
143 | print $taint eq $up |
144 | ? "ok " : "not ok ", ++$cnt, " # compare: $encode, upgrade down\n"; |
145 | |
146 | print pack('a*',$taint) eq pack('a*',$up) |
147 | ? "ok " : "not ok ", ++$cnt, " # bytecmp: $encode, upgrade down\n"; |
148 | |
149 | print is_utf8($taint) |
150 | ? "ok " : "not ok ", ++$cnt, " # is_utf8: $encode, upgrade down\n"; |
151 | |
152 | print tainted($taint) == tainted($arg) |
153 | ? "ok " : "not ok ", ++$cnt, " # tainted: $encode, upgrade down\n"; |
154 | |
155 | my $taint = $arg; substr($taint, 0) = $up; |
156 | utf8::downgrade($taint); |
157 | |
158 | print $taint eq $down |
159 | ? "ok " : "not ok ", ++$cnt, " # compare: $encode, downgrade up\n"; |
160 | |
161 | print pack('a*',$taint) eq pack('a*',$down) |
162 | ? "ok " : "not ok ", ++$cnt, " # bytecmp: $encode, downgrade up\n"; |
163 | |
164 | print !is_utf8($taint) |
165 | ? "ok " : "not ok ", ++$cnt, " # is_utf8: $encode, downgrade up\n"; |
166 | |
167 | print tainted($taint) == tainted($arg) |
168 | ? "ok " : "not ok ", ++$cnt, " # tainted: $encode, downgrade up\n"; |
169 | |
170 | my $taint = $arg; substr($taint, 0) = $down; |
171 | utf8::downgrade($taint); |
172 | |
173 | print $taint eq $down |
174 | ? "ok " : "not ok ", ++$cnt, " # compare: $encode, downgrade down\n"; |
175 | |
176 | print pack('a*',$taint) eq pack('a*',$down) |
177 | ? "ok " : "not ok ", ++$cnt, " # bytecmp: $encode, downgrade down\n"; |
178 | |
179 | print !is_utf8($taint) |
180 | ? "ok " : "not ok ", ++$cnt, " # is_utf8: $encode, downgrade down\n"; |
181 | |
182 | print tainted($taint) == tainted($arg) |
183 | ? "ok " : "not ok ", ++$cnt, " # tainted: $encode, downgrade down\n"; |
184 | } |
185 | |
186 | |