Commit | Line | Data |
---|---|---|
1e422769 | 1 | #!./perl -T |
2 | # | |
3 | # Taint tests by Tom Phoenix <rootbeer@teleport.com>. | |
4 | # | |
5 | # I don't claim to know all about tainting. If anyone sees | |
9607fc9c | 6 | # tests that I've missed here, please add them. But this is |
1e422769 | 7 | # better than having no tests at all, right? |
8 | # | |
9 | ||
10 | BEGIN { | |
11 | chdir 't' if -d 't'; | |
20822f61 | 12 | @INC = '../lib'; |
632e037a NC |
13 | require './test.pl'; |
14 | skip_all_if_miniperl("no dynamic loading on miniperl, no re"); | |
1e422769 | 15 | } |
16 | ||
17 | use strict; | |
18 | use Config; | |
19 | ||
be88a5c3 | 20 | plan tests => 786; |
7c36658b | 21 | |
0ecd3ba2 MG |
22 | $| = 1; |
23 | ||
c9f931b8 JH |
24 | use vars qw($ipcsysv); # did we manage to load IPC::SysV? |
25 | ||
ff504b36 | 26 | my ($old_env_path, $old_env_dcl_path, $old_env_term); |
3eeba6fb | 27 | BEGIN { |
ff504b36 JM |
28 | $old_env_path = $ENV{'PATH'}; |
29 | $old_env_dcl_path = $ENV{'DCL$PATH'}; | |
30 | $old_env_term = $ENV{'TERM'}; | |
3eeba6fb CB |
31 | if ($^O eq 'VMS' && !defined($Config{d_setenv})) { |
32 | $ENV{PATH} = $ENV{PATH}; | |
33 | $ENV{TERM} = $ENV{TERM} ne ''? $ENV{TERM} : 'dummy'; | |
34 | } | |
be3174d2 GS |
35 | if ($Config{'extensions'} =~ /\bIPC\/SysV\b/ |
36 | && ($Config{d_shm} || $Config{d_msg})) { | |
c9f931b8 JH |
37 | eval { require IPC::SysV }; |
38 | unless ($@) { | |
39 | $ipcsysv++; | |
ddc3217d | 40 | IPC::SysV->import(qw(IPC_PRIVATE IPC_RMID IPC_CREAT S_IRWXU IPC_NOWAIT)); |
c9f931b8 | 41 | } |
b9d1c439 | 42 | } |
3eeba6fb CB |
43 | } |
44 | ||
09f04786 MS |
45 | my $Is_VMS = $^O eq 'VMS'; |
46 | my $Is_MSWin32 = $^O eq 'MSWin32'; | |
47 | my $Is_NetWare = $^O eq 'NetWare'; | |
48 | my $Is_Dos = $^O eq 'dos'; | |
49 | my $Is_Cygwin = $^O eq 'cygwin'; | |
8c2c7bd1 | 50 | my $Is_OpenBSD = $^O eq 'openbsd'; |
1fb83d06 | 51 | my $Is_MirBSD = $^O eq 'mirbsd'; |
08322f8f | 52 | my $Invoke_Perl = $Is_VMS ? 'MCR Sys$Disk:[]Perl.exe' : |
09f04786 | 53 | $Is_MSWin32 ? '.\perl' : |
7b903762 | 54 | $Is_NetWare ? 'perl' : |
09f04786 | 55 | './perl' ; |
c90c0ff4 | 56 | my @MoreEnv = qw/IFS CDPATH ENV BASH_ENV/; |
7bac28a0 | 57 | |
1e422769 | 58 | if ($Is_VMS) { |
7bac28a0 | 59 | my (%old, $x); |
60 | for $x ('DCL$PATH', @MoreEnv) { | |
61 | ($old{$x}) = $ENV{$x} =~ /^(.*)$/ if exists $ENV{$x}; | |
62 | } | |
ff504b36 JM |
63 | # VMS note: PATH and TERM are automatically created by the C |
64 | # library in VMS on reference to the their keys in %ENV. | |
65 | # There is currently no way to determine if they did not exist | |
66 | # before this test was run. | |
1e422769 | 67 | eval <<EndOfCleanup; |
68 | END { | |
ff504b36 JM |
69 | \$ENV{PATH} = \$old_env_path; |
70 | warn "# Note: logical name 'PATH' may have been created\n"; | |
71 | \$ENV{'TERM'} = \$old_env_term; | |
72 | warn "# Note: logical name 'TERM' may have been created\n"; | |
562a7b0c | 73 | \@ENV{keys %old} = values %old; |
ff504b36 JM |
74 | if (defined \$old_env_dcl_path) { |
75 | \$ENV{'DCL\$PATH'} = \$old_env_dcl_path; | |
76 | } else { | |
77 | delete \$ENV{'DCL\$PATH'}; | |
78 | } | |
1e422769 | 79 | } |
80 | EndOfCleanup | |
81 | } | |
82 | ||
83 | # Sources of taint: | |
84 | # The empty tainted value, for tainting strings | |
85 | my $TAINT = substr($^X, 0, 0); | |
86 | # A tainted zero, useful for tainting numbers | |
09f04786 MS |
87 | my $TAINT0; |
88 | { | |
89 | no warnings; | |
90 | $TAINT0 = 0 + $TAINT; | |
91 | } | |
1e422769 | 92 | |
93 | # This taints each argument passed. All must be lvalues. | |
94 | # Side effect: It also stringifies them. :-( | |
95 | sub taint_these (@) { | |
96 | for (@_) { $_ .= $TAINT } | |
97 | } | |
98 | ||
99 | # How to identify taint when you see it | |
1e422769 | 100 | sub tainted ($) { |
81cba34d | 101 | not eval { join("",@_), kill 0; 1 }; |
1e422769 | 102 | } |
1e422769 | 103 | |
f37ea7f0 NC |
104 | sub is_tainted { |
105 | my $thing = shift; | |
106 | local $::Level = $::Level + 1; | |
81cba34d | 107 | ok(tainted($thing), @_); |
f37ea7f0 NC |
108 | } |
109 | ||
110 | sub isnt_tainted { | |
111 | my $thing = shift; | |
112 | local $::Level = $::Level + 1; | |
81cba34d | 113 | ok(!tainted($thing), @_); |
f37ea7f0 NC |
114 | } |
115 | ||
8184526b | 116 | sub violates_taint { |
ef5cbc63 NC |
117 | my ($code, $what, $desc) = @_; |
118 | $desc //= $what; | |
8184526b NC |
119 | local $::Level = $::Level + 1; |
120 | is(eval { $code->(); }, undef, $desc); | |
ef5cbc63 | 121 | like($@, qr/^Insecure dependency in $what while running with -T switch/); |
8184526b NC |
122 | } |
123 | ||
1e422769 | 124 | # We need an external program to call. |
7b903762 | 125 | my $ECHO = ($Is_MSWin32 ? ".\\echo$$" : ($Is_NetWare ? "echo$$" : "./echo$$")); |
1e422769 | 126 | END { unlink $ECHO } |
22d7dfed NC |
127 | open my $fh, '>', $ECHO or die "Can't create $ECHO: $!"; |
128 | print $fh 'print "@ARGV\n"', "\n"; | |
129 | close $fh; | |
1e422769 | 130 | my $echo = "$Invoke_Perl $ECHO"; |
131 | ||
22d7dfed | 132 | my $TEST = 'TEST'; |
dc459aad | 133 | |
1e422769 | 134 | # First, let's make sure that Perl is checking the dangerous |
135 | # environment variables. Maybe they aren't set yet, so we'll | |
136 | # taint them ourselves. | |
137 | { | |
138 | $ENV{'DCL$PATH'} = '' if $Is_VMS; | |
139 | ||
e59c8b07 | 140 | $ENV{PATH} = ($Is_Cygwin) ? '/usr/bin' : ''; |
c90c0ff4 | 141 | delete @ENV{@MoreEnv}; |
7bac28a0 | 142 | $ENV{TERM} = 'dumb'; |
143 | ||
c3197de1 | 144 | is(eval { `$echo 1` }, "1\n"); |
09f04786 MS |
145 | |
146 | SKIP: { | |
147 | skip "Environment tainting tests skipped", 4 | |
7b903762 | 148 | if $Is_MSWin32 || $Is_NetWare || $Is_VMS || $Is_Dos; |
7bac28a0 | 149 | |
7bac28a0 | 150 | my @vars = ('PATH', @MoreEnv); |
151 | while (my $v = $vars[0]) { | |
152 | local $ENV{$v} = $TAINT; | |
153 | last if eval { `$echo 1` }; | |
154 | last unless $@ =~ /^Insecure \$ENV{$v}/; | |
155 | shift @vars; | |
156 | } | |
c3197de1 | 157 | is("@vars", ""); |
c90c0ff4 | 158 | |
159 | # tainted $TERM is unsafe only if it contains metachars | |
160 | local $ENV{TERM}; | |
161 | $ENV{TERM} = 'e=mc2'; | |
c3197de1 | 162 | is(eval { `$echo 1` }, "1\n"); |
c90c0ff4 | 163 | $ENV{TERM} = 'e=mc2' . $TAINT; |
c3197de1 NC |
164 | is(eval { `$echo 1` }, undef); |
165 | like($@, qr/^Insecure \$ENV{TERM}/); | |
5aabfad6 | 166 | } |
7bac28a0 | 167 | |
9607fc9c | 168 | my $tmp; |
2986a63f | 169 | if ($^O eq 'os2' || $^O eq 'amigaos' || $Is_MSWin32 || $Is_NetWare || $Is_Dos) { |
48c036b1 GS |
170 | print "# all directories are writeable\n"; |
171 | } | |
172 | else { | |
9607fc9c | 173 | $tmp = (grep { defined and -d and (stat _)[2] & 2 } |
099f76bb | 174 | qw(sys$scratch /tmp /var/tmp /usr/tmp), |
9607fc9c | 175 | @ENV{qw(TMP TEMP)})[0] |
176 | or print "# can't find world-writeable directory to test PATH\n"; | |
177 | } | |
178 | ||
09f04786 MS |
179 | SKIP: { |
180 | skip "all directories are writeable", 2 unless $tmp; | |
181 | ||
7bac28a0 | 182 | local $ENV{PATH} = $tmp; |
c3197de1 NC |
183 | is(eval { `$echo 1` }, undef); |
184 | like($@, qr/^Insecure directory in \$ENV{PATH}/); | |
1e422769 | 185 | } |
186 | ||
09f04786 MS |
187 | SKIP: { |
188 | skip "This is not VMS", 4 unless $Is_VMS; | |
189 | ||
1e422769 | 190 | $ENV{'DCL$PATH'} = $TAINT; |
81e6f6d0 | 191 | is(eval { `$echo 1` }, undef); |
c3197de1 | 192 | like($@, qr/^Insecure \$ENV{DCL\$PATH}/); |
09f04786 MS |
193 | SKIP: { |
194 | skip q[can't find world-writeable directory to test DCL$PATH], 2 | |
25fb98c0 | 195 | unless $tmp; |
09f04786 | 196 | |
9607fc9c | 197 | $ENV{'DCL$PATH'} = $tmp; |
81e6f6d0 | 198 | is(eval { `$echo 1` }, undef); |
c3197de1 | 199 | like($@, qr/^Insecure directory in \$ENV{DCL\$PATH}/); |
9607fc9c | 200 | } |
1e422769 | 201 | $ENV{'DCL$PATH'} = ''; |
202 | } | |
1e422769 | 203 | } |
204 | ||
205 | # Let's see that we can taint and untaint as needed. | |
206 | { | |
207 | my $foo = $TAINT; | |
f37ea7f0 | 208 | is_tainted($foo); |
9607fc9c | 209 | |
210 | # That was a sanity check. If it failed, stop the insanity! | |
211 | die "Taint checks don't seem to be enabled" unless tainted $foo; | |
1e422769 | 212 | |
213 | $foo = "foo"; | |
f37ea7f0 | 214 | isnt_tainted($foo); |
1e422769 | 215 | |
216 | taint_these($foo); | |
f37ea7f0 | 217 | is_tainted($foo); |
1e422769 | 218 | |
219 | my @list = 1..10; | |
81cba34d | 220 | isnt_tainted($_) foreach @list; |
1e422769 | 221 | taint_these @list[1,3,5,7,9]; |
e75436bf | 222 | is_tainted($_) foreach @list[1,3,5,7,9]; |
81cba34d | 223 | isnt_tainted($_) foreach @list[0,2,4,6,8]; |
1e422769 | 224 | |
225 | ($foo) = $foo =~ /(.+)/; | |
f37ea7f0 | 226 | isnt_tainted($foo); |
1e422769 | 227 | |
c769ddc7 DM |
228 | my ($desc, $s, $res, $res2, $one); |
229 | ||
230 | $desc = "match with string tainted"; | |
231 | ||
232 | $s = 'abcd' . $TAINT; | |
233 | $res = $s =~ /(.+)/; | |
234 | $one = $1; | |
f37ea7f0 NC |
235 | is_tainted($s, "$desc: s tainted"); |
236 | isnt_tainted($res, "$desc: res not tainted"); | |
237 | isnt_tainted($one, "$desc: \$1 not tainted"); | |
c769ddc7 DM |
238 | is($res, 1, "$desc: res value"); |
239 | is($one, 'abcd', "$desc: \$1 value"); | |
240 | ||
241 | $desc = "match /g with string tainted"; | |
242 | ||
243 | $s = 'abcd' . $TAINT; | |
244 | $res = $s =~ /(.)/g; | |
245 | $one = $1; | |
f37ea7f0 NC |
246 | is_tainted($s, "$desc: s tainted"); |
247 | isnt_tainted($res, "$desc: res not tainted"); | |
248 | isnt_tainted($one, "$desc: \$1 not tainted"); | |
c769ddc7 DM |
249 | is($res, 1, "$desc: res value"); |
250 | is($one, 'a', "$desc: \$1 value"); | |
251 | ||
252 | $desc = "match with string tainted, list cxt"; | |
253 | ||
254 | $s = 'abcd' . $TAINT; | |
255 | ($res) = $s =~ /(.+)/; | |
256 | $one = $1; | |
f37ea7f0 NC |
257 | is_tainted($s, "$desc: s tainted"); |
258 | isnt_tainted($res, "$desc: res not tainted"); | |
259 | isnt_tainted($one, "$desc: \$1 not tainted"); | |
c769ddc7 DM |
260 | is($res, 'abcd', "$desc: res value"); |
261 | is($one, 'abcd', "$desc: \$1 value"); | |
262 | ||
263 | $desc = "match /g with string tainted, list cxt"; | |
264 | ||
265 | $s = 'abcd' . $TAINT; | |
266 | ($res, $res2) = $s =~ /(.)/g; | |
267 | $one = $1; | |
f37ea7f0 NC |
268 | is_tainted($s, "$desc: s tainted"); |
269 | isnt_tainted($res, "$desc: res not tainted"); | |
270 | isnt_tainted($res2,"$desc: res2 not tainted"); | |
271 | isnt_tainted($one, "$desc: \$1 not tainted"); | |
c769ddc7 DM |
272 | is($res, 'a', "$desc: res value"); |
273 | is($res2,'b', "$desc: res2 value"); | |
274 | is($one, 'd', "$desc: \$1 value"); | |
275 | ||
276 | $desc = "match with pattern tainted"; | |
277 | ||
278 | $s = 'abcd'; | |
279 | $res = $s =~ /$TAINT(.+)/; | |
280 | $one = $1; | |
f37ea7f0 NC |
281 | isnt_tainted($s, "$desc: s not tainted"); |
282 | isnt_tainted($res, "$desc: res not tainted"); | |
283 | is_tainted($one, "$desc: \$1 tainted"); | |
c769ddc7 DM |
284 | is($res, 1, "$desc: res value"); |
285 | is($one, 'abcd', "$desc: \$1 value"); | |
286 | ||
287 | $desc = "match /g with pattern tainted"; | |
288 | ||
289 | $s = 'abcd'; | |
290 | $res = $s =~ /$TAINT(.)/g; | |
291 | $one = $1; | |
f37ea7f0 NC |
292 | isnt_tainted($s, "$desc: s not tainted"); |
293 | isnt_tainted($res, "$desc: res not tainted"); | |
294 | is_tainted($one, "$desc: \$1 tainted"); | |
c769ddc7 DM |
295 | is($res, 1, "$desc: res value"); |
296 | is($one, 'a', "$desc: \$1 value"); | |
297 | ||
298 | $desc = "match with pattern tainted via locale"; | |
299 | ||
300 | $s = 'abcd'; | |
301 | { use locale; $res = $s =~ /(\w+)/; $one = $1; } | |
f37ea7f0 NC |
302 | isnt_tainted($s, "$desc: s not tainted"); |
303 | isnt_tainted($res, "$desc: res not tainted"); | |
304 | is_tainted($one, "$desc: \$1 tainted"); | |
c769ddc7 DM |
305 | is($res, 1, "$desc: res value"); |
306 | is($one, 'abcd', "$desc: \$1 value"); | |
307 | ||
308 | $desc = "match /g with pattern tainted via locale"; | |
309 | ||
310 | $s = 'abcd'; | |
311 | { use locale; $res = $s =~ /(\w)/g; $one = $1; } | |
f37ea7f0 NC |
312 | isnt_tainted($s, "$desc: s not tainted"); |
313 | isnt_tainted($res, "$desc: res not tainted"); | |
314 | is_tainted($one, "$desc: \$1 tainted"); | |
c769ddc7 DM |
315 | is($res, 1, "$desc: res value"); |
316 | is($one, 'a', "$desc: \$1 value"); | |
317 | ||
318 | $desc = "match with pattern tainted, list cxt"; | |
319 | ||
320 | $s = 'abcd'; | |
321 | ($res) = $s =~ /$TAINT(.+)/; | |
322 | $one = $1; | |
f37ea7f0 NC |
323 | isnt_tainted($s, "$desc: s not tainted"); |
324 | is_tainted($res, "$desc: res tainted"); | |
325 | is_tainted($one, "$desc: \$1 tainted"); | |
c769ddc7 DM |
326 | is($res, 'abcd', "$desc: res value"); |
327 | is($one, 'abcd', "$desc: \$1 value"); | |
328 | ||
329 | $desc = "match /g with pattern tainted, list cxt"; | |
330 | ||
331 | $s = 'abcd'; | |
332 | ($res, $res2) = $s =~ /$TAINT(.)/g; | |
333 | $one = $1; | |
f37ea7f0 NC |
334 | isnt_tainted($s, "$desc: s not tainted"); |
335 | is_tainted($res, "$desc: res tainted"); | |
336 | is_tainted($one, "$desc: \$1 tainted"); | |
c769ddc7 DM |
337 | is($res, 'a', "$desc: res value"); |
338 | is($res2,'b', "$desc: res2 value"); | |
339 | is($one, 'd', "$desc: \$1 value"); | |
340 | ||
341 | $desc = "match with pattern tainted via locale, list cxt"; | |
342 | ||
343 | $s = 'abcd'; | |
344 | { use locale; ($res) = $s =~ /(\w+)/; $one = $1; } | |
f37ea7f0 NC |
345 | isnt_tainted($s, "$desc: s not tainted"); |
346 | is_tainted($res, "$desc: res tainted"); | |
347 | is_tainted($one, "$desc: \$1 tainted"); | |
c769ddc7 DM |
348 | is($res, 'abcd', "$desc: res value"); |
349 | is($one, 'abcd', "$desc: \$1 value"); | |
350 | ||
351 | $desc = "match /g with pattern tainted via locale, list cxt"; | |
352 | ||
353 | $s = 'abcd'; | |
354 | { use locale; ($res, $res2) = $s =~ /(\w)/g; $one = $1; } | |
f37ea7f0 NC |
355 | isnt_tainted($s, "$desc: s not tainted"); |
356 | is_tainted($res, "$desc: res tainted"); | |
357 | is_tainted($res2, "$desc: res2 tainted"); | |
358 | is_tainted($one, "$desc: \$1 tainted"); | |
c769ddc7 DM |
359 | is($res, 'a', "$desc: res value"); |
360 | is($res2,'b', "$desc: res2 value"); | |
361 | is($one, 'd', "$desc: \$1 value"); | |
362 | ||
363 | $desc = "substitution with string tainted"; | |
364 | ||
365 | $s = 'abcd' . $TAINT; | |
366 | $res = $s =~ s/(.+)/xyz/; | |
367 | $one = $1; | |
f37ea7f0 NC |
368 | is_tainted($s, "$desc: s tainted"); |
369 | isnt_tainted($res, "$desc: res not tainted"); | |
370 | isnt_tainted($one, "$desc: \$1 not tainted"); | |
c769ddc7 DM |
371 | is($s, 'xyz', "$desc: s value"); |
372 | is($res, 1, "$desc: res value"); | |
373 | is($one, 'abcd', "$desc: \$1 value"); | |
374 | ||
375 | $desc = "substitution /g with string tainted"; | |
376 | ||
377 | $s = 'abcd' . $TAINT; | |
378 | $res = $s =~ s/(.)/x/g; | |
379 | $one = $1; | |
f37ea7f0 NC |
380 | is_tainted($s, "$desc: s tainted"); |
381 | is_tainted($res, "$desc: res tainted"); | |
382 | isnt_tainted($one, "$desc: \$1 not tainted"); | |
c769ddc7 DM |
383 | is($s, 'xxxx', "$desc: s value"); |
384 | is($res, 4, "$desc: res value"); | |
385 | is($one, 'd', "$desc: \$1 value"); | |
386 | ||
387 | $desc = "substitution /r with string tainted"; | |
388 | ||
389 | $s = 'abcd' . $TAINT; | |
390 | $res = $s =~ s/(.+)/xyz/r; | |
391 | $one = $1; | |
f37ea7f0 NC |
392 | is_tainted($s, "$desc: s tainted"); |
393 | is_tainted($res, "$desc: res tainted"); | |
394 | isnt_tainted($one, "$desc: \$1 not tainted"); | |
c769ddc7 DM |
395 | is($s, 'abcd', "$desc: s value"); |
396 | is($res, 'xyz', "$desc: res value"); | |
397 | is($one, 'abcd', "$desc: \$1 value"); | |
398 | ||
20be6587 DM |
399 | $desc = "substitution /e with string tainted"; |
400 | ||
401 | $s = 'abcd' . $TAINT; | |
402 | $one = ''; | |
403 | $res = $s =~ s{(.+)}{ | |
404 | $one = $one . "x"; # make sure code not tainted | |
f37ea7f0 | 405 | isnt_tainted($one, "$desc: code not tainted within /e"); |
20be6587 | 406 | $one = $1; |
f37ea7f0 | 407 | isnt_tainted($one, "$desc: \$1 not tainted within /e"); |
20be6587 DM |
408 | "xyz"; |
409 | }e; | |
410 | $one = $1; | |
f37ea7f0 NC |
411 | is_tainted($s, "$desc: s tainted"); |
412 | isnt_tainted($res, "$desc: res not tainted"); | |
413 | isnt_tainted($one, "$desc: \$1 not tainted"); | |
20be6587 DM |
414 | is($s, 'xyz', "$desc: s value"); |
415 | is($res, 1, "$desc: res value"); | |
416 | is($one, 'abcd', "$desc: \$1 value"); | |
417 | ||
c769ddc7 DM |
418 | $desc = "substitution with pattern tainted"; |
419 | ||
420 | $s = 'abcd'; | |
421 | $res = $s =~ s/$TAINT(.+)/xyz/; | |
422 | $one = $1; | |
f37ea7f0 NC |
423 | is_tainted($s, "$desc: s tainted"); |
424 | isnt_tainted($res, "$desc: res not tainted"); | |
425 | is_tainted($one, "$desc: \$1 tainted"); | |
c769ddc7 DM |
426 | is($s, 'xyz', "$desc: s value"); |
427 | is($res, 1, "$desc: res value"); | |
428 | is($one, 'abcd', "$desc: \$1 value"); | |
429 | ||
430 | $desc = "substitution /g with pattern tainted"; | |
431 | ||
432 | $s = 'abcd'; | |
433 | $res = $s =~ s/$TAINT(.)/x/g; | |
434 | $one = $1; | |
f37ea7f0 NC |
435 | is_tainted($s, "$desc: s tainted"); |
436 | is_tainted($res, "$desc: res tainted"); | |
437 | is_tainted($one, "$desc: \$1 tainted"); | |
c769ddc7 DM |
438 | is($s, 'xxxx', "$desc: s value"); |
439 | is($res, 4, "$desc: res value"); | |
440 | is($one, 'd', "$desc: \$1 value"); | |
441 | ||
20be6587 DM |
442 | $desc = "substitution /ge with pattern tainted"; |
443 | ||
444 | $s = 'abc'; | |
445 | { | |
446 | my $i = 0; | |
447 | my $j; | |
448 | $res = $s =~ s{(.)$TAINT}{ | |
449 | $j = $i; # make sure code not tainted | |
450 | $one = $1; | |
f37ea7f0 | 451 | isnt_tainted($j, "$desc: code not tainted within /e"); |
20be6587 DM |
452 | $i++; |
453 | if ($i == 1) { | |
f37ea7f0 | 454 | isnt_tainted($s, "$desc: s not tainted loop 1"); |
20be6587 DM |
455 | } |
456 | else { | |
f37ea7f0 | 457 | is_tainted($s, "$desc: s tainted loop $i"); |
20be6587 | 458 | } |
f37ea7f0 | 459 | is_tainted($one, "$desc: \$1 tainted loop $i"); |
20be6587 DM |
460 | $i.$TAINT; |
461 | }ge; | |
462 | $one = $1; | |
463 | } | |
f37ea7f0 NC |
464 | is_tainted($s, "$desc: s tainted"); |
465 | is_tainted($res, "$desc: res tainted"); | |
466 | is_tainted($one, "$desc: \$1 tainted"); | |
20be6587 DM |
467 | is($s, '123', "$desc: s value"); |
468 | is($res, 3, "$desc: res value"); | |
469 | is($one, 'c', "$desc: \$1 value"); | |
470 | ||
c769ddc7 DM |
471 | $desc = "substitution /r with pattern tainted"; |
472 | ||
473 | $s = 'abcd'; | |
474 | $res = $s =~ s/$TAINT(.+)/xyz/r; | |
475 | $one = $1; | |
f37ea7f0 NC |
476 | isnt_tainted($s, "$desc: s not tainted"); |
477 | is_tainted($res, "$desc: res tainted"); | |
478 | is_tainted($one, "$desc: \$1 tainted"); | |
c769ddc7 DM |
479 | is($s, 'abcd', "$desc: s value"); |
480 | is($res, 'xyz', "$desc: res value"); | |
481 | is($one, 'abcd', "$desc: \$1 value"); | |
482 | ||
483 | $desc = "substitution with pattern tainted via locale"; | |
484 | ||
485 | $s = 'abcd'; | |
486 | { use locale; $res = $s =~ s/(\w+)/xyz/; $one = $1; } | |
f37ea7f0 NC |
487 | is_tainted($s, "$desc: s tainted"); |
488 | isnt_tainted($res, "$desc: res not tainted"); | |
489 | is_tainted($one, "$desc: \$1 tainted"); | |
c769ddc7 DM |
490 | is($s, 'xyz', "$desc: s value"); |
491 | is($res, 1, "$desc: res value"); | |
492 | is($one, 'abcd', "$desc: \$1 value"); | |
493 | ||
494 | $desc = "substitution /g with pattern tainted via locale"; | |
495 | ||
496 | $s = 'abcd'; | |
497 | { use locale; $res = $s =~ s/(\w)/x/g; $one = $1; } | |
f37ea7f0 NC |
498 | is_tainted($s, "$desc: s tainted"); |
499 | is_tainted($res, "$desc: res tainted"); | |
500 | is_tainted($one, "$desc: \$1 tainted"); | |
c769ddc7 DM |
501 | is($s, 'xxxx', "$desc: s value"); |
502 | is($res, 4, "$desc: res value"); | |
503 | is($one, 'd', "$desc: \$1 value"); | |
504 | ||
505 | $desc = "substitution /r with pattern tainted via locale"; | |
506 | ||
507 | $s = 'abcd'; | |
508 | { use locale; $res = $s =~ s/(\w+)/xyz/r; $one = $1; } | |
f37ea7f0 NC |
509 | isnt_tainted($s, "$desc: s not tainted"); |
510 | is_tainted($res, "$desc: res tainted"); | |
511 | is_tainted($one, "$desc: \$1 tainted"); | |
c769ddc7 DM |
512 | is($s, 'abcd', "$desc: s value"); |
513 | is($res, 'xyz', "$desc: res value"); | |
514 | is($one, 'abcd', "$desc: \$1 value"); | |
515 | ||
516 | $desc = "substitution with replacement tainted"; | |
517 | ||
518 | $s = 'abcd'; | |
519 | $res = $s =~ s/(.+)/xyz$TAINT/; | |
520 | $one = $1; | |
f37ea7f0 NC |
521 | is_tainted($s, "$desc: s tainted"); |
522 | isnt_tainted($res, "$desc: res not tainted"); | |
523 | isnt_tainted($one, "$desc: \$1 not tainted"); | |
c769ddc7 DM |
524 | is($s, 'xyz', "$desc: s value"); |
525 | is($res, 1, "$desc: res value"); | |
526 | is($one, 'abcd', "$desc: \$1 value"); | |
527 | ||
528 | $desc = "substitution /g with replacement tainted"; | |
529 | ||
530 | $s = 'abcd'; | |
531 | $res = $s =~ s/(.)/x$TAINT/g; | |
532 | $one = $1; | |
f37ea7f0 NC |
533 | is_tainted($s, "$desc: s tainted"); |
534 | isnt_tainted($res, "$desc: res not tainted"); | |
535 | isnt_tainted($one, "$desc: \$1 not tainted"); | |
c769ddc7 DM |
536 | is($s, 'xxxx', "$desc: s value"); |
537 | is($res, 4, "$desc: res value"); | |
538 | is($one, 'd', "$desc: \$1 value"); | |
539 | ||
20be6587 DM |
540 | $desc = "substitution /ge with replacement tainted"; |
541 | ||
542 | $s = 'abc'; | |
543 | { | |
544 | my $i = 0; | |
545 | my $j; | |
546 | $res = $s =~ s{(.)}{ | |
547 | $j = $i; # make sure code not tainted | |
548 | $one = $1; | |
f37ea7f0 | 549 | isnt_tainted($j, "$desc: code not tainted within /e"); |
20be6587 DM |
550 | $i++; |
551 | if ($i == 1) { | |
f37ea7f0 | 552 | isnt_tainted($s, "$desc: s not tainted loop 1"); |
20be6587 DM |
553 | } |
554 | else { | |
f37ea7f0 | 555 | is_tainted($s, "$desc: s tainted loop $i"); |
20be6587 | 556 | } |
f37ea7f0 | 557 | isnt_tainted($one, "$desc: \$1 not tainted within /e"); |
20be6587 DM |
558 | $i.$TAINT; |
559 | }ge; | |
560 | $one = $1; | |
561 | } | |
f37ea7f0 NC |
562 | is_tainted($s, "$desc: s tainted"); |
563 | is_tainted($res, "$desc: res tainted"); | |
564 | isnt_tainted($one, "$desc: \$1 not tainted"); | |
20be6587 DM |
565 | is($s, '123', "$desc: s value"); |
566 | is($res, 3, "$desc: res value"); | |
567 | is($one, 'c', "$desc: \$1 value"); | |
568 | ||
c769ddc7 DM |
569 | $desc = "substitution /r with replacement tainted"; |
570 | ||
571 | $s = 'abcd'; | |
572 | $res = $s =~ s/(.+)/xyz$TAINT/r; | |
573 | $one = $1; | |
f37ea7f0 NC |
574 | isnt_tainted($s, "$desc: s not tainted"); |
575 | is_tainted($res, "$desc: res tainted"); | |
576 | isnt_tainted($one, "$desc: \$1 not tainted"); | |
c769ddc7 DM |
577 | is($s, 'abcd', "$desc: s value"); |
578 | is($res, 'xyz', "$desc: res value"); | |
579 | is($one, 'abcd', "$desc: \$1 value"); | |
1e422769 | 580 | |
b3eb6a9b | 581 | { |
c769ddc7 DM |
582 | # now do them all again with "use re 'taint" |
583 | ||
584 | use re 'taint'; | |
585 | ||
586 | $desc = "use re 'taint': match with string tainted"; | |
587 | ||
588 | $s = 'abcd' . $TAINT; | |
589 | $res = $s =~ /(.+)/; | |
590 | $one = $1; | |
f37ea7f0 NC |
591 | is_tainted($s, "$desc: s tainted"); |
592 | isnt_tainted($res, "$desc: res not tainted"); | |
593 | is_tainted($one, "$desc: \$1 tainted"); | |
c769ddc7 DM |
594 | is($res, 1, "$desc: res value"); |
595 | is($one, 'abcd', "$desc: \$1 value"); | |
596 | ||
597 | $desc = "use re 'taint': match /g with string tainted"; | |
598 | ||
599 | $s = 'abcd' . $TAINT; | |
600 | $res = $s =~ /(.)/g; | |
601 | $one = $1; | |
f37ea7f0 NC |
602 | is_tainted($s, "$desc: s tainted"); |
603 | isnt_tainted($res, "$desc: res not tainted"); | |
604 | is_tainted($one, "$desc: \$1 tainted"); | |
c769ddc7 DM |
605 | is($res, 1, "$desc: res value"); |
606 | is($one, 'a', "$desc: \$1 value"); | |
607 | ||
608 | $desc = "use re 'taint': match with string tainted, list cxt"; | |
609 | ||
610 | $s = 'abcd' . $TAINT; | |
611 | ($res) = $s =~ /(.+)/; | |
612 | $one = $1; | |
f37ea7f0 NC |
613 | is_tainted($s, "$desc: s tainted"); |
614 | is_tainted($res, "$desc: res tainted"); | |
615 | is_tainted($one, "$desc: \$1 tainted"); | |
c769ddc7 DM |
616 | is($res, 'abcd', "$desc: res value"); |
617 | is($one, 'abcd', "$desc: \$1 value"); | |
618 | ||
619 | $desc = "use re 'taint': match /g with string tainted, list cxt"; | |
620 | ||
621 | $s = 'abcd' . $TAINT; | |
622 | ($res, $res2) = $s =~ /(.)/g; | |
623 | $one = $1; | |
f37ea7f0 NC |
624 | is_tainted($s, "$desc: s tainted"); |
625 | is_tainted($res, "$desc: res tainted"); | |
626 | is_tainted($res2, "$desc: res2 tainted"); | |
627 | is_tainted($one, "$desc: \$1 not tainted"); | |
c769ddc7 DM |
628 | is($res, 'a', "$desc: res value"); |
629 | is($res2,'b', "$desc: res2 value"); | |
630 | is($one, 'd', "$desc: \$1 value"); | |
631 | ||
632 | $desc = "use re 'taint': match with pattern tainted"; | |
633 | ||
634 | $s = 'abcd'; | |
635 | $res = $s =~ /$TAINT(.+)/; | |
636 | $one = $1; | |
f37ea7f0 NC |
637 | isnt_tainted($s, "$desc: s not tainted"); |
638 | isnt_tainted($res, "$desc: res not tainted"); | |
639 | is_tainted($one, "$desc: \$1 tainted"); | |
c769ddc7 DM |
640 | is($res, 1, "$desc: res value"); |
641 | is($one, 'abcd', "$desc: \$1 value"); | |
642 | ||
643 | $desc = "use re 'taint': match /g with pattern tainted"; | |
644 | ||
645 | $s = 'abcd'; | |
646 | $res = $s =~ /$TAINT(.)/g; | |
647 | $one = $1; | |
f37ea7f0 NC |
648 | isnt_tainted($s, "$desc: s not tainted"); |
649 | isnt_tainted($res, "$desc: res not tainted"); | |
650 | is_tainted($one, "$desc: \$1 tainted"); | |
c769ddc7 DM |
651 | is($res, 1, "$desc: res value"); |
652 | is($one, 'a', "$desc: \$1 value"); | |
653 | ||
654 | $desc = "use re 'taint': match with pattern tainted via locale"; | |
655 | ||
656 | $s = 'abcd'; | |
657 | { use locale; $res = $s =~ /(\w+)/; $one = $1; } | |
f37ea7f0 NC |
658 | isnt_tainted($s, "$desc: s not tainted"); |
659 | isnt_tainted($res, "$desc: res not tainted"); | |
660 | is_tainted($one, "$desc: \$1 tainted"); | |
c769ddc7 DM |
661 | is($res, 1, "$desc: res value"); |
662 | is($one, 'abcd', "$desc: \$1 value"); | |
663 | ||
664 | $desc = "use re 'taint': match /g with pattern tainted via locale"; | |
665 | ||
666 | $s = 'abcd'; | |
667 | { use locale; $res = $s =~ /(\w)/g; $one = $1; } | |
f37ea7f0 NC |
668 | isnt_tainted($s, "$desc: s not tainted"); |
669 | isnt_tainted($res, "$desc: res not tainted"); | |
670 | is_tainted($one, "$desc: \$1 tainted"); | |
c769ddc7 DM |
671 | is($res, 1, "$desc: res value"); |
672 | is($one, 'a', "$desc: \$1 value"); | |
673 | ||
674 | $desc = "use re 'taint': match with pattern tainted, list cxt"; | |
675 | ||
676 | $s = 'abcd'; | |
677 | ($res) = $s =~ /$TAINT(.+)/; | |
678 | $one = $1; | |
f37ea7f0 NC |
679 | isnt_tainted($s, "$desc: s not tainted"); |
680 | is_tainted($res, "$desc: res tainted"); | |
681 | is_tainted($one, "$desc: \$1 tainted"); | |
c769ddc7 DM |
682 | is($res, 'abcd', "$desc: res value"); |
683 | is($one, 'abcd', "$desc: \$1 value"); | |
684 | ||
685 | $desc = "use re 'taint': match /g with pattern tainted, list cxt"; | |
686 | ||
687 | $s = 'abcd'; | |
688 | ($res, $res2) = $s =~ /$TAINT(.)/g; | |
689 | $one = $1; | |
f37ea7f0 NC |
690 | isnt_tainted($s, "$desc: s not tainted"); |
691 | is_tainted($res, "$desc: res tainted"); | |
692 | is_tainted($one, "$desc: \$1 tainted"); | |
c769ddc7 DM |
693 | is($res, 'a', "$desc: res value"); |
694 | is($res2,'b', "$desc: res2 value"); | |
695 | is($one, 'd', "$desc: \$1 value"); | |
696 | ||
697 | $desc = "use re 'taint': match with pattern tainted via locale, list cxt"; | |
698 | ||
699 | $s = 'abcd'; | |
700 | { use locale; ($res) = $s =~ /(\w+)/; $one = $1; } | |
f37ea7f0 NC |
701 | isnt_tainted($s, "$desc: s not tainted"); |
702 | is_tainted($res, "$desc: res tainted"); | |
703 | is_tainted($one, "$desc: \$1 tainted"); | |
c769ddc7 DM |
704 | is($res, 'abcd', "$desc: res value"); |
705 | is($one, 'abcd', "$desc: \$1 value"); | |
706 | ||
707 | $desc = "use re 'taint': match /g with pattern tainted via locale, list cxt"; | |
708 | ||
709 | $s = 'abcd'; | |
710 | { use locale; ($res, $res2) = $s =~ /(\w)/g; $one = $1; } | |
f37ea7f0 NC |
711 | isnt_tainted($s, "$desc: s not tainted"); |
712 | is_tainted($res, "$desc: res tainted"); | |
713 | is_tainted($res2, "$desc: res2 tainted"); | |
714 | is_tainted($one, "$desc: \$1 tainted"); | |
c769ddc7 DM |
715 | is($res, 'a', "$desc: res value"); |
716 | is($res2,'b', "$desc: res2 value"); | |
717 | is($one, 'd', "$desc: \$1 value"); | |
718 | ||
719 | $desc = "use re 'taint': substitution with string tainted"; | |
720 | ||
721 | $s = 'abcd' . $TAINT; | |
722 | $res = $s =~ s/(.+)/xyz/; | |
723 | $one = $1; | |
f37ea7f0 NC |
724 | is_tainted($s, "$desc: s tainted"); |
725 | isnt_tainted($res, "$desc: res not tainted"); | |
726 | is_tainted($one, "$desc: \$1 tainted"); | |
c769ddc7 DM |
727 | is($s, 'xyz', "$desc: s value"); |
728 | is($res, 1, "$desc: res value"); | |
729 | is($one, 'abcd', "$desc: \$1 value"); | |
730 | ||
731 | $desc = "use re 'taint': substitution /g with string tainted"; | |
732 | ||
733 | $s = 'abcd' . $TAINT; | |
734 | $res = $s =~ s/(.)/x/g; | |
735 | $one = $1; | |
f37ea7f0 NC |
736 | is_tainted($s, "$desc: s tainted"); |
737 | is_tainted($res, "$desc: res tainted"); | |
738 | is_tainted($one, "$desc: \$1 tainted"); | |
c769ddc7 DM |
739 | is($s, 'xxxx', "$desc: s value"); |
740 | is($res, 4, "$desc: res value"); | |
741 | is($one, 'd', "$desc: \$1 value"); | |
742 | ||
743 | $desc = "use re 'taint': substitution /r with string tainted"; | |
744 | ||
745 | $s = 'abcd' . $TAINT; | |
746 | $res = $s =~ s/(.+)/xyz/r; | |
747 | $one = $1; | |
f37ea7f0 NC |
748 | is_tainted($s, "$desc: s tainted"); |
749 | is_tainted($res, "$desc: res tainted"); | |
750 | is_tainted($one, "$desc: \$1 tainted"); | |
c769ddc7 DM |
751 | is($s, 'abcd', "$desc: s value"); |
752 | is($res, 'xyz', "$desc: res value"); | |
753 | is($one, 'abcd', "$desc: \$1 value"); | |
754 | ||
20be6587 DM |
755 | $desc = "use re 'taint': substitution /e with string tainted"; |
756 | ||
757 | $s = 'abcd' . $TAINT; | |
758 | $one = ''; | |
759 | $res = $s =~ s{(.+)}{ | |
760 | $one = $one . "x"; # make sure code not tainted | |
f37ea7f0 | 761 | isnt_tainted($one, "$desc: code not tainted within /e"); |
20be6587 | 762 | $one = $1; |
f37ea7f0 | 763 | is_tainted($one, "$desc: $1 tainted within /e"); |
20be6587 DM |
764 | "xyz"; |
765 | }e; | |
766 | $one = $1; | |
f37ea7f0 NC |
767 | is_tainted($s, "$desc: s tainted"); |
768 | isnt_tainted($res, "$desc: res not tainted"); | |
769 | is_tainted($one, "$desc: \$1 tainted"); | |
20be6587 DM |
770 | is($s, 'xyz', "$desc: s value"); |
771 | is($res, 1, "$desc: res value"); | |
772 | is($one, 'abcd', "$desc: \$1 value"); | |
773 | ||
c769ddc7 DM |
774 | $desc = "use re 'taint': substitution with pattern tainted"; |
775 | ||
776 | $s = 'abcd'; | |
777 | $res = $s =~ s/$TAINT(.+)/xyz/; | |
778 | $one = $1; | |
f37ea7f0 NC |
779 | is_tainted($s, "$desc: s tainted"); |
780 | isnt_tainted($res, "$desc: res not tainted"); | |
781 | is_tainted($one, "$desc: \$1 tainted"); | |
c769ddc7 DM |
782 | is($s, 'xyz', "$desc: s value"); |
783 | is($res, 1, "$desc: res value"); | |
784 | is($one, 'abcd', "$desc: \$1 value"); | |
785 | ||
786 | $desc = "use re 'taint': substitution /g with pattern tainted"; | |
787 | ||
788 | $s = 'abcd'; | |
789 | $res = $s =~ s/$TAINT(.)/x/g; | |
790 | $one = $1; | |
f37ea7f0 NC |
791 | is_tainted($s, "$desc: s tainted"); |
792 | is_tainted($res, "$desc: res tainted"); | |
793 | is_tainted($one, "$desc: \$1 tainted"); | |
c769ddc7 DM |
794 | is($s, 'xxxx', "$desc: s value"); |
795 | is($res, 4, "$desc: res value"); | |
796 | is($one, 'd', "$desc: \$1 value"); | |
797 | ||
20be6587 DM |
798 | $desc = "use re 'taint': substitution /ge with pattern tainted"; |
799 | ||
800 | $s = 'abc'; | |
801 | { | |
802 | my $i = 0; | |
803 | my $j; | |
804 | $res = $s =~ s{(.)$TAINT}{ | |
805 | $j = $i; # make sure code not tainted | |
806 | $one = $1; | |
f37ea7f0 | 807 | isnt_tainted($j, "$desc: code not tainted within /e"); |
20be6587 DM |
808 | $i++; |
809 | if ($i == 1) { | |
f37ea7f0 | 810 | isnt_tainted($s, "$desc: s not tainted loop 1"); |
20be6587 DM |
811 | } |
812 | else { | |
f37ea7f0 | 813 | is_tainted($s, "$desc: s tainted loop $i"); |
20be6587 | 814 | } |
f37ea7f0 | 815 | is_tainted($one, "$desc: \$1 tainted loop $i"); |
20be6587 DM |
816 | $i.$TAINT; |
817 | }ge; | |
818 | $one = $1; | |
819 | } | |
f37ea7f0 NC |
820 | is_tainted($s, "$desc: s tainted"); |
821 | is_tainted($res, "$desc: res tainted"); | |
822 | is_tainted($one, "$desc: \$1 tainted"); | |
20be6587 DM |
823 | is($s, '123', "$desc: s value"); |
824 | is($res, 3, "$desc: res value"); | |
825 | is($one, 'c', "$desc: \$1 value"); | |
826 | ||
827 | ||
c769ddc7 DM |
828 | $desc = "use re 'taint': substitution /r with pattern tainted"; |
829 | ||
830 | $s = 'abcd'; | |
831 | $res = $s =~ s/$TAINT(.+)/xyz/r; | |
832 | $one = $1; | |
f37ea7f0 NC |
833 | isnt_tainted($s, "$desc: s not tainted"); |
834 | is_tainted($res, "$desc: res tainted"); | |
835 | is_tainted($one, "$desc: \$1 tainted"); | |
c769ddc7 DM |
836 | is($s, 'abcd', "$desc: s value"); |
837 | is($res, 'xyz', "$desc: res value"); | |
838 | is($one, 'abcd', "$desc: \$1 value"); | |
839 | ||
840 | $desc = "use re 'taint': substitution with pattern tainted via locale"; | |
841 | ||
842 | $s = 'abcd'; | |
843 | { use locale; $res = $s =~ s/(\w+)/xyz/; $one = $1; } | |
f37ea7f0 NC |
844 | is_tainted($s, "$desc: s tainted"); |
845 | isnt_tainted($res, "$desc: res not tainted"); | |
846 | is_tainted($one, "$desc: \$1 tainted"); | |
c769ddc7 DM |
847 | is($s, 'xyz', "$desc: s value"); |
848 | is($res, 1, "$desc: res value"); | |
849 | is($one, 'abcd', "$desc: \$1 value"); | |
850 | ||
851 | $desc = "use re 'taint': substitution /g with pattern tainted via locale"; | |
852 | ||
853 | $s = 'abcd'; | |
854 | { use locale; $res = $s =~ s/(\w)/x/g; $one = $1; } | |
f37ea7f0 NC |
855 | is_tainted($s, "$desc: s tainted"); |
856 | is_tainted($res, "$desc: res tainted"); | |
857 | is_tainted($one, "$desc: \$1 tainted"); | |
c769ddc7 DM |
858 | is($s, 'xxxx', "$desc: s value"); |
859 | is($res, 4, "$desc: res value"); | |
860 | is($one, 'd', "$desc: \$1 value"); | |
861 | ||
862 | $desc = "use re 'taint': substitution /r with pattern tainted via locale"; | |
863 | ||
864 | $s = 'abcd'; | |
865 | { use locale; $res = $s =~ s/(\w+)/xyz/r; $one = $1; } | |
f37ea7f0 NC |
866 | isnt_tainted($s, "$desc: s not tainted"); |
867 | is_tainted($res, "$desc: res tainted"); | |
868 | is_tainted($one, "$desc: \$1 tainted"); | |
c769ddc7 DM |
869 | is($s, 'abcd', "$desc: s value"); |
870 | is($res, 'xyz', "$desc: res value"); | |
871 | is($one, 'abcd', "$desc: \$1 value"); | |
872 | ||
873 | $desc = "use re 'taint': substitution with replacement tainted"; | |
874 | ||
875 | $s = 'abcd'; | |
876 | $res = $s =~ s/(.+)/xyz$TAINT/; | |
877 | $one = $1; | |
f37ea7f0 NC |
878 | is_tainted($s, "$desc: s tainted"); |
879 | isnt_tainted($res, "$desc: res not tainted"); | |
880 | isnt_tainted($one, "$desc: \$1 not tainted"); | |
c769ddc7 DM |
881 | is($s, 'xyz', "$desc: s value"); |
882 | is($res, 1, "$desc: res value"); | |
883 | is($one, 'abcd', "$desc: \$1 value"); | |
884 | ||
885 | $desc = "use re 'taint': substitution /g with replacement tainted"; | |
886 | ||
887 | $s = 'abcd'; | |
888 | $res = $s =~ s/(.)/x$TAINT/g; | |
889 | $one = $1; | |
f37ea7f0 NC |
890 | is_tainted($s, "$desc: s tainted"); |
891 | isnt_tainted($res, "$desc: res not tainted"); | |
892 | isnt_tainted($one, "$desc: \$1 not tainted"); | |
c769ddc7 DM |
893 | is($s, 'xxxx', "$desc: s value"); |
894 | is($res, 4, "$desc: res value"); | |
895 | is($one, 'd', "$desc: \$1 value"); | |
896 | ||
20be6587 DM |
897 | $desc = "use re 'taint': substitution /ge with replacement tainted"; |
898 | ||
899 | $s = 'abc'; | |
900 | { | |
901 | my $i = 0; | |
902 | my $j; | |
903 | $res = $s =~ s{(.)}{ | |
904 | $j = $i; # make sure code not tainted | |
905 | $one = $1; | |
f37ea7f0 | 906 | isnt_tainted($j, "$desc: code not tainted within /e"); |
20be6587 DM |
907 | $i++; |
908 | if ($i == 1) { | |
f37ea7f0 | 909 | isnt_tainted($s, "$desc: s not tainted loop 1"); |
20be6587 DM |
910 | } |
911 | else { | |
f37ea7f0 | 912 | is_tainted($s, "$desc: s tainted loop $i"); |
20be6587 | 913 | } |
f37ea7f0 | 914 | isnt_tainted($one, "$desc: \$1 not tainted"); |
20be6587 DM |
915 | $i.$TAINT; |
916 | }ge; | |
917 | $one = $1; | |
918 | } | |
f37ea7f0 NC |
919 | is_tainted($s, "$desc: s tainted"); |
920 | is_tainted($res, "$desc: res tainted"); | |
921 | isnt_tainted($one, "$desc: \$1 not tainted"); | |
20be6587 DM |
922 | is($s, '123', "$desc: s value"); |
923 | is($res, 3, "$desc: res value"); | |
924 | is($one, 'c', "$desc: \$1 value"); | |
925 | ||
c769ddc7 DM |
926 | $desc = "use re 'taint': substitution /r with replacement tainted"; |
927 | ||
928 | $s = 'abcd'; | |
929 | $res = $s =~ s/(.+)/xyz$TAINT/r; | |
930 | $one = $1; | |
f37ea7f0 NC |
931 | isnt_tainted($s, "$desc: s not tainted"); |
932 | is_tainted($res, "$desc: res tainted"); | |
933 | isnt_tainted($one, "$desc: \$1 not tainted"); | |
c769ddc7 DM |
934 | is($s, 'abcd', "$desc: s value"); |
935 | is($res, 'xyz', "$desc: res value"); | |
936 | is($one, 'abcd', "$desc: \$1 value"); | |
b3eb6a9b GS |
937 | } |
938 | ||
939 | $foo = $1 if 'bar' =~ /(.+)$TAINT/; | |
f37ea7f0 | 940 | is_tainted($foo); |
c3197de1 | 941 | is($foo, 'bar'); |
48c036b1 | 942 | |
1e422769 | 943 | my $pi = 4 * atan2(1,1) + $TAINT0; |
f37ea7f0 | 944 | is_tainted($pi); |
1e422769 | 945 | |
946 | ($pi) = $pi =~ /(\d+\.\d+)/; | |
f37ea7f0 | 947 | isnt_tainted($pi); |
c3197de1 | 948 | is(sprintf("%.5f", $pi), '3.14159'); |
1e422769 | 949 | } |
950 | ||
951 | # How about command-line arguments? The problem is that we don't | |
952 | # always get some, so we'll run another process with some. | |
dc459aad | 953 | SKIP: { |
1ab9acc5 | 954 | my $arg = tempfile(); |
22d7dfed NC |
955 | open $fh, '>', $arg or die "Can't create $arg: $!"; |
956 | print $fh q{ | |
1e422769 | 957 | eval { join('', @ARGV), kill 0 }; |
958 | exit 0 if $@ =~ /^Insecure dependency/; | |
959 | print "# Oops: \$@ was [$@]\n"; | |
960 | exit 1; | |
961 | }; | |
22d7dfed | 962 | close $fh or die "Can't close $arg: $!"; |
1e422769 | 963 | print `$Invoke_Perl "-T" $arg and some suspect arguments`; |
c3197de1 | 964 | is($?, 0, "Exited with status $?"); |
1e422769 | 965 | unlink $arg; |
966 | } | |
967 | ||
968 | # Reading from a file should be tainted | |
969 | { | |
22d7dfed | 970 | ok(open my $fh, '<', $TEST) or diag("Couldn't open '$TEST': $!"); |
1e422769 | 971 | |
972 | my $block; | |
22d7dfed NC |
973 | sysread($fh, $block, 100); |
974 | my $line = <$fh>; | |
975 | close $fh; | |
f37ea7f0 NC |
976 | is_tainted($block); |
977 | is_tainted($line); | |
1e422769 | 978 | } |
979 | ||
1e422769 | 980 | # Output of commands should be tainted |
981 | { | |
982 | my $foo = `$echo abc`; | |
f37ea7f0 | 983 | is_tainted($foo); |
1e422769 | 984 | } |
985 | ||
986 | # Certain system variables should be tainted | |
987 | { | |
e75436bf NC |
988 | is_tainted($^X); |
989 | is_tainted($0); | |
1e422769 | 990 | } |
991 | ||
992 | # Results of matching should all be untainted | |
993 | { | |
994 | my $foo = "abcdefghi" . $TAINT; | |
f37ea7f0 | 995 | is_tainted($foo); |
1e422769 | 996 | |
997 | $foo =~ /def/; | |
81cba34d NC |
998 | isnt_tainted($`); |
999 | isnt_tainted($&); | |
1000 | isnt_tainted($'); | |
1e422769 | 1001 | |
1002 | $foo =~ /(...)(...)(...)/; | |
81cba34d NC |
1003 | isnt_tainted($1); |
1004 | isnt_tainted($2); | |
1005 | isnt_tainted($3); | |
1006 | isnt_tainted($+); | |
1e422769 | 1007 | |
1008 | my @bar = $foo =~ /(...)(...)(...)/; | |
81cba34d | 1009 | isnt_tainted($_) foreach @bar; |
1e422769 | 1010 | |
f37ea7f0 | 1011 | is_tainted($foo); # $foo should still be tainted! |
c3197de1 | 1012 | is($foo, "abcdefghi"); |
1e422769 | 1013 | } |
1014 | ||
1015 | # Operations which affect files can't use tainted data. | |
1016 | { | |
8184526b | 1017 | violates_taint(sub { chmod 0, $TAINT }, 'chmod'); |
1e422769 | 1018 | |
e2b4a08c NC |
1019 | SKIP: { |
1020 | skip "truncate() is not available", 2 unless $Config{d_truncate}; | |
1021 | ||
8184526b | 1022 | violates_taint(sub { truncate 'NoSuChFiLe', $TAINT0 }, 'truncate'); |
e2b4a08c | 1023 | } |
1e422769 | 1024 | |
8184526b NC |
1025 | violates_taint(sub { rename '', $TAINT }, 'rename'); |
1026 | violates_taint(sub { unlink $TAINT }, 'unlink'); | |
1027 | violates_taint(sub { utime $TAINT }, 'utime'); | |
48c036b1 | 1028 | |
09f04786 MS |
1029 | SKIP: { |
1030 | skip "chown() is not available", 2 unless $Config{d_chown}; | |
1e422769 | 1031 | |
8184526b | 1032 | violates_taint(sub { chown -1, -1, $TAINT }, 'chown'); |
1e422769 | 1033 | } |
1034 | ||
09f04786 MS |
1035 | SKIP: { |
1036 | skip "link() is not available", 2 unless $Config{d_link}; | |
1037 | ||
8184526b | 1038 | violates_taint(sub { link $TAINT, '' }, 'link'); |
1e422769 | 1039 | } |
09f04786 MS |
1040 | |
1041 | SKIP: { | |
1042 | skip "symlink() is not available", 2 unless $Config{d_symlink}; | |
1043 | ||
8184526b | 1044 | violates_taint(sub { symlink $TAINT, '' }, 'symlink'); |
1e422769 | 1045 | } |
1046 | } | |
1047 | ||
1048 | # Operations which affect directories can't use tainted data. | |
1049 | { | |
8184526b NC |
1050 | violates_taint(sub { mkdir "foo".$TAINT, 0755 . $TAINT0 }, 'mkdir'); |
1051 | violates_taint(sub { rmdir $TAINT }, 'rmdir'); | |
1052 | violates_taint(sub { chdir "foo".$TAINT }, 'chdir'); | |
48c036b1 | 1053 | |
09f04786 MS |
1054 | SKIP: { |
1055 | skip "chroot() is not available", 2 unless $Config{d_chroot}; | |
1056 | ||
8184526b | 1057 | violates_taint(sub { chroot $TAINT }, 'chroot'); |
1e422769 | 1058 | } |
1059 | } | |
1060 | ||
1061 | # Some operations using files can't use tainted data. | |
1062 | { | |
1063 | my $foo = "imaginary library" . $TAINT; | |
8184526b | 1064 | violates_taint(sub { require $foo }, 'require'); |
1e422769 | 1065 | |
1c25d394 | 1066 | my $filename = tempfile(); # NB: $filename isn't tainted! |
1e422769 | 1067 | $foo = $filename . $TAINT; |
1068 | unlink $filename; # in any case | |
1069 | ||
c3197de1 | 1070 | is(eval { open FOO, $foo }, undef, 'open for read'); |
8184526b | 1071 | is($@, ''); # NB: This should be allowed |
22d7dfed NC |
1072 | is(eval { open my $fh, , '<', $foo }, undef, 'open for read'); |
1073 | is($@, ''); # NB: This should be allowed | |
9d116dd7 JH |
1074 | |
1075 | # Try first new style but allow also old style. | |
327ccce1 YST |
1076 | # We do not want the whole taint.t to fail |
1077 | # just because Errno possibly failing. | |
c3197de1 | 1078 | ok(eval('$!{ENOENT}') || |
61ae2fbf | 1079 | $! == 2 || # File not found |
c3197de1 | 1080 | ($Is_Dos && $! == 22)); |
1e422769 | 1081 | |
ef5cbc63 | 1082 | violates_taint(sub { open FOO, "> $foo" }, 'open', 'open for write'); |
22d7dfed | 1083 | violates_taint(sub { open my $fh, '>', $foo }, 'open', 'open for write'); |
1e422769 | 1084 | } |
1085 | ||
1086 | # Commands to the system can't use tainted data | |
1087 | { | |
1088 | my $foo = $TAINT; | |
1089 | ||
09f04786 | 1090 | SKIP: { |
22d7dfed | 1091 | skip "open('|') is not available", 8 if $^O eq 'amigaos'; |
09f04786 | 1092 | |
22d7dfed NC |
1093 | violates_taint(sub { open FOO, "| x$foo" }, 'piped open', 'popen to'); |
1094 | violates_taint(sub { open FOO, "x$foo |" }, 'piped open', 'popen from'); | |
1095 | violates_taint(sub { open my $fh, '|-', "x$foo" }, 'piped open', 'popen to'); | |
1096 | violates_taint(sub { open my $fh, '-|', "x$foo" }, 'piped open', 'popen from'); | |
48c036b1 | 1097 | } |
1e422769 | 1098 | |
8184526b NC |
1099 | violates_taint(sub { exec $TAINT }, 'exec'); |
1100 | violates_taint(sub { system $TAINT }, 'system'); | |
48c036b1 | 1101 | |
1e422769 | 1102 | $foo = "*"; |
1103 | taint_these $foo; | |
1104 | ||
ef5cbc63 | 1105 | violates_taint(sub { `$echo 1$foo` }, '``', 'backticks'); |
1e422769 | 1106 | |
09f04786 MS |
1107 | SKIP: { |
1108 | # wildcard expansion doesn't invoke shell on VMS, so is safe | |
1109 | skip "This is not VMS", 2 unless $Is_VMS; | |
1110 | ||
c3197de1 NC |
1111 | isnt(join('', eval { glob $foo } ), '', 'globbing'); |
1112 | is($@, ''); | |
1e422769 | 1113 | } |
1114 | } | |
1115 | ||
1116 | # Operations which affect processes can't use tainted data. | |
1117 | { | |
8184526b | 1118 | violates_taint(sub { kill 0, $TAINT }, 'kill'); |
1e422769 | 1119 | |
09f04786 MS |
1120 | SKIP: { |
1121 | skip "setpgrp() is not available", 2 unless $Config{d_setpgrp}; | |
1e422769 | 1122 | |
8184526b | 1123 | violates_taint(sub { setpgrp 0, $TAINT0 }, 'setpgrp'); |
1e422769 | 1124 | } |
09f04786 MS |
1125 | |
1126 | SKIP: { | |
1127 | skip "setpriority() is not available", 2 unless $Config{d_setprior}; | |
1128 | ||
8184526b | 1129 | violates_taint(sub { setpriority 0, $TAINT0, $TAINT0 }, 'setpriority'); |
1e422769 | 1130 | } |
1131 | } | |
1132 | ||
1133 | # Some miscellaneous operations can't use tainted data. | |
1134 | { | |
09f04786 MS |
1135 | SKIP: { |
1136 | skip "syscall() is not available", 2 unless $Config{d_syscall}; | |
1137 | ||
8184526b | 1138 | violates_taint(sub { syscall $TAINT }, 'syscall'); |
1e422769 | 1139 | } |
1140 | ||
1141 | { | |
1142 | my $foo = "x" x 979; | |
1143 | taint_these $foo; | |
1144 | local *FOO; | |
1c25d394 | 1145 | my $temp = tempfile(); |
c3197de1 | 1146 | ok(open FOO, "> $temp") or diag("Couldn't open $temp for write: $!"); |
8184526b | 1147 | violates_taint(sub { ioctl FOO, $TAINT0, $foo }, 'ioctl'); |
1e422769 | 1148 | |
22d7dfed NC |
1149 | my $temp2 = tempfile(); |
1150 | ok(open my $fh, '>', $temp2) or diag("Couldn't open $temp2 for write: $!"); | |
1151 | violates_taint(sub { ioctl $fh, $TAINT0, $foo }, 'ioctl'); | |
1152 | ||
09f04786 | 1153 | SKIP: { |
22d7dfed | 1154 | skip "fcntl() is not available", 4 unless $Config{d_fcntl}; |
09f04786 | 1155 | |
8184526b | 1156 | violates_taint(sub { fcntl FOO, $TAINT0, $foo }, 'fcntl'); |
22d7dfed | 1157 | violates_taint(sub { fcntl $fh, $TAINT0, $foo }, 'fcntl'); |
1e422769 | 1158 | } |
1159 | ||
1160 | close FOO; | |
1161 | } | |
1162 | } | |
1163 | ||
9607fc9c | 1164 | # Some tests involving references |
1e422769 | 1165 | { |
1166 | my $foo = 'abc' . $TAINT; | |
1167 | my $fooref = \$foo; | |
f37ea7f0 NC |
1168 | isnt_tainted($fooref); |
1169 | is_tainted($$fooref); | |
1170 | is_tainted($foo); | |
1e422769 | 1171 | } |
54310121 | 1172 | |
1173 | # Some tests involving assignment | |
1174 | { | |
1175 | my $foo = $TAINT0; | |
1176 | my $bar = $foo; | |
e75436bf NC |
1177 | is_tainted($foo); |
1178 | is_tainted($bar); | |
f37ea7f0 NC |
1179 | is_tainted($foo = $bar); |
1180 | is_tainted($bar = $bar); | |
1181 | is_tainted($bar += $bar); | |
1182 | is_tainted($bar -= $bar); | |
1183 | is_tainted($bar *= $bar); | |
1184 | is_tainted($bar++); | |
1185 | is_tainted($bar /= $bar); | |
1186 | is_tainted($bar += 0); | |
1187 | is_tainted($bar -= 2); | |
1188 | is_tainted($bar *= -1); | |
1189 | is_tainted($bar /= 1); | |
1190 | is_tainted($bar--); | |
c3197de1 | 1191 | is($bar, 0); |
54310121 | 1192 | } |
a1f49e72 CS |
1193 | |
1194 | # Test assignment and return of lists | |
1195 | { | |
1196 | my @foo = ("A", "tainted" . $TAINT, "B"); | |
f37ea7f0 NC |
1197 | isnt_tainted($foo[0]); |
1198 | is_tainted( $foo[1]); | |
1199 | isnt_tainted($foo[2]); | |
a1f49e72 | 1200 | my @bar = @foo; |
f37ea7f0 NC |
1201 | isnt_tainted($bar[0]); |
1202 | is_tainted( $bar[1]); | |
1203 | isnt_tainted($bar[2]); | |
a1f49e72 | 1204 | my @baz = eval { "A", "tainted" . $TAINT, "B" }; |
f37ea7f0 NC |
1205 | isnt_tainted($baz[0]); |
1206 | is_tainted( $baz[1]); | |
1207 | isnt_tainted($baz[2]); | |
a1f49e72 | 1208 | my @plugh = eval q[ "A", "tainted" . $TAINT, "B" ]; |
f37ea7f0 NC |
1209 | isnt_tainted($plugh[0]); |
1210 | is_tainted( $plugh[1]); | |
1211 | isnt_tainted($plugh[2]); | |
a1f49e72 | 1212 | my $nautilus = sub { "A", "tainted" . $TAINT, "B" }; |
f37ea7f0 NC |
1213 | isnt_tainted(((&$nautilus)[0])); |
1214 | is_tainted( ((&$nautilus)[1])); | |
1215 | isnt_tainted(((&$nautilus)[2])); | |
a1f49e72 | 1216 | my @xyzzy = &$nautilus; |
f37ea7f0 NC |
1217 | isnt_tainted($xyzzy[0]); |
1218 | is_tainted( $xyzzy[1]); | |
1219 | isnt_tainted($xyzzy[2]); | |
a1f49e72 | 1220 | my $red_october = sub { return "A", "tainted" . $TAINT, "B" }; |
f37ea7f0 NC |
1221 | isnt_tainted(((&$red_october)[0])); |
1222 | is_tainted( ((&$red_october)[1])); | |
1223 | isnt_tainted(((&$red_october)[2])); | |
a1f49e72 | 1224 | my @corge = &$red_october; |
f37ea7f0 NC |
1225 | isnt_tainted($corge[0]); |
1226 | is_tainted( $corge[1]); | |
1227 | isnt_tainted($corge[2]); | |
a1f49e72 | 1228 | } |
fb73857a | 1229 | |
1230 | # Test for system/library calls returning string data of dubious origin. | |
1231 | { | |
1232 | # No reliable %Config check for getpw* | |
09f04786 | 1233 | SKIP: { |
f37ea7f0 | 1234 | skip "getpwent() is not available", 9 unless |
09f04786 MS |
1235 | eval { setpwent(); getpwent() }; |
1236 | ||
fb73857a | 1237 | setpwent(); |
1238 | my @getpwent = getpwent(); | |
1239 | die "getpwent: $!\n" unless (@getpwent); | |
f37ea7f0 NC |
1240 | isnt_tainted($getpwent[0]); |
1241 | is_tainted($getpwent[1]); | |
1242 | isnt_tainted($getpwent[2]); | |
1243 | isnt_tainted($getpwent[3]); | |
1244 | isnt_tainted($getpwent[4]); | |
1245 | isnt_tainted($getpwent[5]); | |
1246 | is_tainted($getpwent[6], 'ge?cos'); | |
1247 | isnt_tainted($getpwent[7]); | |
1248 | is_tainted($getpwent[8], 'shell'); | |
fb73857a | 1249 | endpwent(); |
fb73857a | 1250 | } |
1251 | ||
09f04786 MS |
1252 | SKIP: { |
1253 | # pretty hard to imagine not | |
1254 | skip "readdir() is not available", 1 unless $Config{d_readdir}; | |
1255 | ||
22d7dfed NC |
1256 | opendir my $dh, "op" or die "opendir: $!\n"; |
1257 | my $readdir = readdir $dh; | |
f37ea7f0 | 1258 | is_tainted($readdir); |
22d7dfed | 1259 | closedir $dh; |
fb73857a | 1260 | } |
1261 | ||
09f04786 MS |
1262 | SKIP: { |
1263 | skip "readlink() or symlink() is not available" unless | |
1264 | $Config{d_readlink} && $Config{d_symlink}; | |
1265 | ||
fb73857a | 1266 | my $symlink = "sl$$"; |
1267 | unlink($symlink); | |
dc459aad JH |
1268 | my $sl = "/something/naughty"; |
1269 | # it has to be a real path on Mac OS | |
dc459aad | 1270 | symlink($sl, $symlink) or die "symlink: $!\n"; |
fb73857a | 1271 | my $readlink = readlink($symlink); |
f37ea7f0 | 1272 | is_tainted($readlink); |
fb73857a | 1273 | unlink($symlink); |
fb73857a | 1274 | } |
1275 | } | |
1276 | ||
1277 | # test bitwise ops (regression bug) | |
1278 | { | |
1279 | my $why = "y"; | |
1280 | my $j = "x" | $why; | |
f37ea7f0 | 1281 | isnt_tainted($j); |
fb73857a | 1282 | $why = $TAINT."y"; |
1283 | $j = "x" | $why; | |
f37ea7f0 | 1284 | is_tainted( $j); |
fb73857a | 1285 | } |
1286 | ||
48c036b1 GS |
1287 | # test target of substitution (regression bug) |
1288 | { | |
1289 | my $why = $TAINT."y"; | |
1290 | $why =~ s/y/z/; | |
f37ea7f0 | 1291 | is_tainted( $why); |
48c036b1 GS |
1292 | |
1293 | my $z = "[z]"; | |
1294 | $why =~ s/$z/zee/; | |
f37ea7f0 | 1295 | is_tainted( $why); |
48c036b1 GS |
1296 | |
1297 | $why =~ s/e/'-'.$$/ge; | |
f37ea7f0 | 1298 | is_tainted( $why); |
48c036b1 | 1299 | } |
d929ce6f | 1300 | |
09f04786 MS |
1301 | |
1302 | SKIP: { | |
1303 | skip "no IPC::SysV", 2 unless $ipcsysv; | |
1304 | ||
1305 | # test shmread | |
1306 | SKIP: { | |
1307 | skip "shm*() not available", 1 unless $Config{d_shm}; | |
1308 | ||
1309 | no strict 'subs'; | |
1310 | my $sent = "foobar"; | |
1311 | my $rcvd; | |
1312 | my $size = 2000; | |
1313 | my $id = shmget(IPC_PRIVATE, $size, S_IRWXU); | |
1314 | ||
1315 | if (defined $id) { | |
1316 | if (shmwrite($id, $sent, 0, 60)) { | |
1317 | if (shmread($id, $rcvd, 0, 60)) { | |
1318 | substr($rcvd, index($rcvd, "\0")) = ''; | |
1319 | } else { | |
1320 | warn "# shmread failed: $!\n"; | |
1321 | } | |
1322 | } else { | |
1323 | warn "# shmwrite failed: $!\n"; | |
1324 | } | |
1325 | shmctl($id, IPC_RMID, 0) or warn "# shmctl failed: $!\n"; | |
1326 | } else { | |
1327 | warn "# shmget failed: $!\n"; | |
1328 | } | |
1329 | ||
1330 | skip "SysV shared memory operation failed", 1 unless | |
1331 | $rcvd eq $sent; | |
1332 | ||
f37ea7f0 | 1333 | is_tainted($rcvd); |
c9f931b8 | 1334 | } |
c2e66d9e | 1335 | |
d929ce6f | 1336 | |
09f04786 MS |
1337 | # test msgrcv |
1338 | SKIP: { | |
1339 | skip "msg*() not available", 1 unless $Config{d_msg}; | |
41d6edb2 | 1340 | |
b9d1c439 | 1341 | no strict 'subs'; |
41d6edb2 JH |
1342 | my $id = msgget(IPC_PRIVATE, IPC_CREAT | S_IRWXU); |
1343 | ||
1344 | my $sent = "message"; | |
1345 | my $type_sent = 1234; | |
1346 | my $rcvd; | |
1347 | my $type_rcvd; | |
1348 | ||
1349 | if (defined $id) { | |
ddc3217d JH |
1350 | if (msgsnd($id, pack("l! a*", $type_sent, $sent), IPC_NOWAIT)) { |
1351 | if (msgrcv($id, $rcvd, 60, 0, IPC_NOWAIT)) { | |
41d6edb2 JH |
1352 | ($type_rcvd, $rcvd) = unpack("l! a*", $rcvd); |
1353 | } else { | |
ddc3217d | 1354 | warn "# msgrcv failed: $!\n"; |
41d6edb2 JH |
1355 | } |
1356 | } else { | |
ddc3217d | 1357 | warn "# msgsnd failed: $!\n"; |
41d6edb2 | 1358 | } |
c2e66d9e | 1359 | msgctl($id, IPC_RMID, 0) or warn "# msgctl failed: $!\n"; |
41d6edb2 JH |
1360 | } else { |
1361 | warn "# msgget failed\n"; | |
1362 | } | |
1363 | ||
09f04786 MS |
1364 | SKIP: { |
1365 | skip "SysV message queue operation failed", 1 | |
1366 | unless $rcvd eq $sent && $type_sent == $type_rcvd; | |
1367 | ||
f37ea7f0 | 1368 | is_tainted($rcvd); |
41d6edb2 | 1369 | } |
41d6edb2 JH |
1370 | } |
1371 | } | |
1372 | ||
3887d568 AP |
1373 | { |
1374 | # bug id 20001004.006 | |
1375 | ||
22d7dfed | 1376 | open my $fh, '<', $TEST or warn "$0: cannot read $TEST: $!" ; |
3887d568 | 1377 | local $/; |
22d7dfed NC |
1378 | my $a = <$fh>; |
1379 | my $b = <$fh>; | |
09f04786 | 1380 | |
f37ea7f0 NC |
1381 | is_tainted($a); |
1382 | is_tainted($b); | |
1383 | is($b, undef); | |
3887d568 | 1384 | } |
27c9684d AP |
1385 | |
1386 | { | |
1387 | # bug id 20001004.007 | |
1388 | ||
22d7dfed NC |
1389 | open my $fh, '<', $TEST or warn "$0: cannot read $TEST: $!" ; |
1390 | my $a = <$fh>; | |
27c9684d AP |
1391 | |
1392 | my $c = { a => 42, | |
1393 | b => $a }; | |
09f04786 | 1394 | |
f37ea7f0 NC |
1395 | isnt_tainted($c->{a}); |
1396 | is_tainted($c->{b}); | |
09f04786 | 1397 | |
27c9684d AP |
1398 | |
1399 | my $d = { a => $a, | |
1400 | b => 42 }; | |
f37ea7f0 NC |
1401 | is_tainted($d->{a}); |
1402 | isnt_tainted($d->{b}); | |
09f04786 | 1403 | |
27c9684d AP |
1404 | |
1405 | my $e = { a => 42, | |
1406 | b => { c => $a, d => 42 } }; | |
f37ea7f0 NC |
1407 | isnt_tainted($e->{a}); |
1408 | isnt_tainted($e->{b}); | |
1409 | is_tainted($e->{b}->{c}); | |
1410 | isnt_tainted($e->{b}->{d}); | |
27c9684d AP |
1411 | } |
1412 | ||
b94c04ac JH |
1413 | { |
1414 | # bug id 20010519.003 | |
1415 | ||
248c32c0 JH |
1416 | BEGIN { |
1417 | use vars qw($has_fcntl); | |
1418 | eval { require Fcntl; import Fcntl; }; | |
1419 | unless ($@) { | |
1420 | $has_fcntl = 1; | |
1421 | } | |
1422 | } | |
b94c04ac | 1423 | |
09f04786 MS |
1424 | SKIP: { |
1425 | skip "no Fcntl", 18 unless $has_fcntl; | |
1426 | ||
281a340f NC |
1427 | my $foo = tempfile(); |
1428 | my $evil = $foo . $TAINT; | |
248c32c0 | 1429 | |
4e74b85b NC |
1430 | is(eval { sysopen(my $ro, $evil, &O_RDONLY) }, undef); |
1431 | is($@, ''); | |
1432 | ||
1433 | violates_taint(sub { sysopen(my $wo, $evil, &O_WRONLY) }, 'sysopen'); | |
1434 | violates_taint(sub { sysopen(my $rw, $evil, &O_RDWR) }, 'sysopen'); | |
1435 | violates_taint(sub { sysopen(my $ap, $evil, &O_APPEND) }, 'sysopen'); | |
1436 | violates_taint(sub { sysopen(my $cr, $evil, &O_CREAT) }, 'sysopen'); | |
1437 | violates_taint(sub { sysopen(my $tr, $evil, &O_TRUNC) }, 'sysopen'); | |
1438 | ||
1439 | is(eval { sysopen(my $ro, $foo, &O_RDONLY | $TAINT0) }, undef); | |
1440 | is($@, ''); | |
1441 | ||
1442 | violates_taint(sub { sysopen(my $wo, $foo, &O_WRONLY | $TAINT0) }, 'sysopen'); | |
1443 | violates_taint(sub { sysopen(my $rw, $foo, &O_RDWR | $TAINT0) }, 'sysopen'); | |
1444 | violates_taint(sub { sysopen(my $ap, $foo, &O_APPEND | $TAINT0) }, 'sysopen'); | |
1445 | violates_taint(sub { sysopen(my $cr, $foo, &O_CREAT | $TAINT0) }, 'sysopen'); | |
1446 | violates_taint(sub { sysopen(my $tr, $foo, &O_TRUNC | $TAINT0) }, 'sysopen'); | |
1447 | is(eval { sysopen(my $ro, $foo, &O_RDONLY, $TAINT0) }, undef); | |
1448 | is($@, ''); | |
1449 | ||
1450 | violates_taint(sub { sysopen(my $wo, $foo, &O_WRONLY, $TAINT0) }, 'sysopen'); | |
1451 | violates_taint(sub { sysopen(my $rw, $foo, &O_RDWR, $TAINT0) }, 'sysopen'); | |
1452 | violates_taint(sub { sysopen(my $ap, $foo, &O_APPEND, $TAINT0) }, 'sysopen'); | |
1453 | violates_taint(sub { sysopen(my $cr, $foo, &O_CREAT, $TAINT0) }, 'sysopen'); | |
1454 | violates_taint(sub { sysopen(my $tr, $foo, &O_TRUNC, $TAINT0) }, 'sysopen'); | |
248c32c0 | 1455 | } |
b94c04ac JH |
1456 | } |
1457 | ||
65811bc3 JH |
1458 | { |
1459 | # bug 20010526.004 | |
1460 | ||
1461 | use warnings; | |
1462 | ||
09f04786 | 1463 | my $saw_warning = 0; |
c3197de1 | 1464 | local $SIG{__WARN__} = sub { ++$saw_warning }; |
65811bc3 JH |
1465 | |
1466 | sub fmi { | |
1467 | my $divnum = shift()/1; | |
1468 | sprintf("%1.1f\n", $divnum); | |
1469 | } | |
1470 | ||
1471 | fmi(21 . $TAINT); | |
1472 | fmi(37); | |
1473 | fmi(248); | |
1474 | ||
c3197de1 | 1475 | is($saw_warning, 0); |
65811bc3 JH |
1476 | } |
1477 | ||
9e1b5a4e A |
1478 | |
1479 | { | |
1480 | # Bug ID 20010730.010 | |
1481 | ||
1482 | my $i = 0; | |
1483 | ||
1484 | sub Tie::TIESCALAR { | |
1485 | my $class = shift; | |
1486 | my $arg = shift; | |
1487 | ||
1488 | bless \$arg => $class; | |
1489 | } | |
1490 | ||
1491 | sub Tie::FETCH { | |
1492 | $i ++; | |
1493 | ${$_ [0]} | |
1494 | } | |
1495 | ||
1496 | ||
1497 | package main; | |
1498 | ||
1499 | my $bar = "The Big Bright Green Pleasure Machine"; | |
1500 | taint_these $bar; | |
1501 | tie my ($foo), Tie => $bar; | |
1502 | ||
1503 | my $baz = $foo; | |
1504 | ||
09f04786 | 1505 | ok $i == 1; |
9e1b5a4e A |
1506 | } |
1507 | ||
8852b6d2 JH |
1508 | { |
1509 | # Check that all environment variables are tainted. | |
1510 | my @untainted; | |
1511 | while (my ($k, $v) = each %ENV) { | |
1512 | if (!tainted($v) && | |
eb25aaf6 HS |
1513 | # These we have explicitly untainted or set earlier. |
1514 | $k !~ /^(BASH_ENV|CDPATH|ENV|IFS|PATH|PERL_CORE|TEMP|TERM|TMP)$/) { | |
8852b6d2 JH |
1515 | push @untainted, "# '$k' = '$v'\n"; |
1516 | } | |
1517 | } | |
c3197de1 | 1518 | is("@untainted", ""); |
8852b6d2 | 1519 | } |
9e1b5a4e A |
1520 | |
1521 | ||
433f4d03 | 1522 | is(${^TAINT}, 1, '$^TAINT is on'); |
7c36658b MS |
1523 | |
1524 | eval { ${^TAINT} = 0 }; | |
433f4d03 NC |
1525 | is(${^TAINT}, 1, '$^TAINT is not assignable'); |
1526 | like($@, qr/^Modification of a read-only value attempted/, | |
1527 | 'Assigning to ${^TAINT} fails'); | |
7c36658b | 1528 | |
e08e52cf AMS |
1529 | { |
1530 | # bug 20011111.105 | |
1531 | ||
1532 | my $re1 = qr/x$TAINT/; | |
f37ea7f0 | 1533 | is_tainted($re1); |
e08e52cf AMS |
1534 | |
1535 | my $re2 = qr/^$re1\z/; | |
f37ea7f0 | 1536 | is_tainted($re2); |
e08e52cf AMS |
1537 | |
1538 | my $re3 = "$re2"; | |
f37ea7f0 | 1539 | is_tainted($re3); |
e08e52cf | 1540 | } |
52a55424 | 1541 | |
09f04786 MS |
1542 | SKIP: { |
1543 | skip "system {} has different semantics on Win32", 1 if $Is_MSWin32; | |
1544 | ||
52a55424 RG |
1545 | # bug 20010221.005 |
1546 | local $ENV{PATH} .= $TAINT; | |
1547 | eval { system { "echo" } "/arg0", "arg1" }; | |
c3197de1 | 1548 | like($@, qr/^Insecure \$ENV/); |
52a55424 | 1549 | } |
09f04786 MS |
1550 | |
1551 | TODO: { | |
1552 | todo_skip 'tainted %ENV warning occludes tainted arguments warning', 22 | |
1553 | if $Is_VMS; | |
1554 | ||
1555 | # bug 20020208.005 plus some single arg exec/system extras | |
8184526b NC |
1556 | violates_taint(sub { exec $TAINT, $TAINT }, 'exec'); |
1557 | violates_taint(sub { exec $TAINT $TAINT }, 'exec'); | |
1558 | violates_taint(sub { exec $TAINT $TAINT, $TAINT }, 'exec'); | |
1559 | violates_taint(sub { exec $TAINT 'notaint' }, 'exec'); | |
1560 | violates_taint(sub { exec {'notaint'} $TAINT }, 'exec'); | |
1561 | ||
1562 | violates_taint(sub { system $TAINT, $TAINT }, 'system'); | |
1563 | violates_taint(sub { system $TAINT $TAINT }, 'system'); | |
1564 | violates_taint(sub { system $TAINT $TAINT, $TAINT }, 'system'); | |
1565 | violates_taint(sub { system $TAINT 'notaint' }, 'system'); | |
1566 | violates_taint(sub { system {'notaint'} $TAINT }, 'system'); | |
09f04786 MS |
1567 | |
1568 | eval { | |
1569 | no warnings; | |
1570 | system("lskdfj does not exist","with","args"); | |
1571 | }; | |
c3197de1 | 1572 | is($@, ""); |
09f04786 | 1573 | |
7b903762 RGS |
1574 | eval { |
1575 | no warnings; | |
1576 | exec("lskdfj does not exist","with","args"); | |
1577 | }; | |
c3197de1 | 1578 | is($@, ""); |
6c8794e1 JH |
1579 | |
1580 | # If you add tests here update also the above skip block for VMS. | |
bbd7eb8a | 1581 | } |
a8c7c11a HS |
1582 | |
1583 | { | |
1584 | # [ID 20020704.001] taint propagation failure | |
1585 | use re 'taint'; | |
1586 | $TAINT =~ /(.*)/; | |
f37ea7f0 | 1587 | is_tainted(my $foo = $1); |
a8c7c11a | 1588 | } |
7b756e0a RGS |
1589 | |
1590 | { | |
c038024b RGS |
1591 | # [perl #24291] this used to dump core |
1592 | our %nonmagicalenv = ( PATH => "util" ); | |
7b756e0a RGS |
1593 | local *ENV = \%nonmagicalenv; |
1594 | eval { system("lskdfj"); }; | |
c3197de1 | 1595 | like($@, qr/^%ENV is aliased to another variable while running with -T switch/); |
c038024b | 1596 | local *ENV = *nonmagicalenv; |
7b756e0a | 1597 | eval { system("lskdfj"); }; |
c3197de1 | 1598 | like($@, qr/^%ENV is aliased to %nonmagicalenv while running with -T switch/); |
7b756e0a | 1599 | } |
0b4182de RD |
1600 | { |
1601 | # [perl #24248] | |
1602 | $TAINT =~ /(.*)/; | |
f37ea7f0 | 1603 | isnt_tainted($1); |
0b4182de | 1604 | my $notaint = $1; |
f37ea7f0 | 1605 | isnt_tainted($notaint); |
0b4182de RD |
1606 | |
1607 | my $l; | |
1608 | $notaint =~ /($notaint)/; | |
1609 | $l = $1; | |
f37ea7f0 NC |
1610 | isnt_tainted($1); |
1611 | isnt_tainted($l); | |
0b4182de RD |
1612 | $notaint =~ /($TAINT)/; |
1613 | $l = $1; | |
f37ea7f0 NC |
1614 | is_tainted($1); |
1615 | is_tainted($l); | |
0b4182de RD |
1616 | |
1617 | $TAINT =~ /($notaint)/; | |
1618 | $l = $1; | |
f37ea7f0 NC |
1619 | isnt_tainted($1); |
1620 | isnt_tainted($l); | |
0b4182de RD |
1621 | $TAINT =~ /($TAINT)/; |
1622 | $l = $1; | |
f37ea7f0 NC |
1623 | is_tainted($1); |
1624 | is_tainted($l); | |
0b4182de RD |
1625 | |
1626 | my $r; | |
1627 | ($r = $TAINT) =~ /($notaint)/; | |
f37ea7f0 | 1628 | isnt_tainted($1); |
0b4182de | 1629 | ($r = $TAINT) =~ /($TAINT)/; |
f37ea7f0 | 1630 | is_tainted($1); |
3511154c DM |
1631 | |
1632 | # [perl #24674] | |
1633 | # accessing $^O shoudn't taint it as a side-effect; | |
1634 | # assigning tainted data to it is now an error | |
1635 | ||
f37ea7f0 | 1636 | isnt_tainted($^O); |
3511154c | 1637 | if (!$^X) { } elsif ($^O eq 'bar') { } |
f37ea7f0 | 1638 | isnt_tainted($^O); |
4b24804c | 1639 | local $^O; # We're going to clobber something test infrastructure depends on. |
3511154c | 1640 | eval '$^O = $^X'; |
c3197de1 | 1641 | like($@, qr/Insecure dependency in/); |
0b4182de | 1642 | } |
23634c10 AL |
1643 | |
1644 | EFFECTIVELY_CONSTANTS: { | |
1645 | my $tainted_number = 12 + $TAINT0; | |
f37ea7f0 | 1646 | is_tainted( $tainted_number ); |
23634c10 AL |
1647 | |
1648 | # Even though it's always 0, it's still tainted | |
1649 | my $tainted_product = $tainted_number * 0; | |
f37ea7f0 | 1650 | is_tainted( $tainted_product ); |
c3197de1 | 1651 | is($tainted_product, 0); |
23634c10 AL |
1652 | } |
1653 | ||
1654 | TERNARY_CONDITIONALS: { | |
1655 | my $tainted_true = $TAINT . "blah blah blah"; | |
1656 | my $tainted_false = $TAINT0; | |
f37ea7f0 NC |
1657 | is_tainted( $tainted_true ); |
1658 | is_tainted( $tainted_false ); | |
23634c10 AL |
1659 | |
1660 | my $result = $tainted_true ? "True" : "False"; | |
c3197de1 | 1661 | is($result, "True"); |
f37ea7f0 | 1662 | isnt_tainted( $result ); |
23634c10 AL |
1663 | |
1664 | $result = $tainted_false ? "True" : "False"; | |
c3197de1 | 1665 | is($result, "False"); |
f37ea7f0 | 1666 | isnt_tainted( $result ); |
23634c10 AL |
1667 | |
1668 | my $untainted_whatever = "The Fabulous Johnny Cash"; | |
1669 | my $tainted_whatever = "Soft Cell" . $TAINT; | |
1670 | ||
1671 | $result = $tainted_true ? $tainted_whatever : $untainted_whatever; | |
c3197de1 | 1672 | is($result, "Soft Cell"); |
f37ea7f0 | 1673 | is_tainted( $result ); |
23634c10 AL |
1674 | |
1675 | $result = $tainted_false ? $tainted_whatever : $untainted_whatever; | |
c3197de1 | 1676 | is($result, "The Fabulous Johnny Cash"); |
f37ea7f0 | 1677 | isnt_tainted( $result ); |
23634c10 | 1678 | } |
65814f21 MS |
1679 | |
1680 | { | |
1681 | # rt.perl.org 5900 $1 remains tainted if... | |
1682 | # 1) The regular expression contains a scalar variable AND | |
1683 | # 2) The regular expression appears in an elsif clause | |
1684 | ||
1685 | my $foo = "abcdefghi" . $TAINT; | |
1686 | ||
1687 | my $valid_chars = 'a-z'; | |
1688 | if ( $foo eq '' ) { | |
1689 | } | |
1690 | elsif ( $foo =~ /([$valid_chars]+)/o ) { | |
81cba34d NC |
1691 | isnt_tainted($1); |
1692 | isnt($1, undef); | |
65814f21 MS |
1693 | } |
1694 | ||
1695 | if ( $foo eq '' ) { | |
1696 | } | |
1697 | elsif ( my @bar = $foo =~ /([$valid_chars]+)/o ) { | |
81cba34d NC |
1698 | isnt_tainted($bar[0]); |
1699 | is(scalar @bar, 1); | |
65814f21 MS |
1700 | } |
1701 | } | |
0a9c116b DM |
1702 | |
1703 | # at scope exit, a restored localised value should have its old | |
1704 | # taint status, not the taint status of the current statement | |
1705 | ||
1706 | { | |
1707 | our $x99 = $^X; | |
f37ea7f0 | 1708 | is_tainted($x99); |
0a9c116b DM |
1709 | |
1710 | $x99 = ''; | |
f37ea7f0 | 1711 | isnt_tainted($x99); |
0a9c116b DM |
1712 | |
1713 | my $c = do { local $x99; $^X }; | |
f37ea7f0 | 1714 | isnt_tainted($x99); |
0a9c116b DM |
1715 | } |
1716 | { | |
1717 | our $x99 = $^X; | |
f37ea7f0 | 1718 | is_tainted($x99); |
0a9c116b DM |
1719 | |
1720 | my $c = do { local $x99; '' }; | |
f37ea7f0 | 1721 | is_tainted($x99); |
0a9c116b DM |
1722 | } |
1723 | ||
27cc343c DM |
1724 | # an mg_get of a tainted value during localization shouldn't taint the |
1725 | # statement | |
1726 | ||
1727 | { | |
1728 | eval { local $0, eval '1' }; | |
c3197de1 | 1729 | is($@, ''); |
27cc343c | 1730 | } |
e26a4975 DM |
1731 | |
1732 | # [perl #8262] //g loops infinitely on tainted data | |
1733 | ||
1734 | { | |
1735 | my @a; | |
fd69380d DM |
1736 | $a[0] = $^X . '-'; |
1737 | $a[0]=~ m/(.)/g; | |
1738 | cmp_ok pos($a[0]), '>', 0, "infinite m//g on arrays (aelemfast)"; | |
1739 | ||
1740 | my $i = 1; | |
1741 | $a[$i] = $^X . '-'; | |
1742 | $a[$i]=~ m/(.)/g; | |
1743 | cmp_ok pos($a[$i]), '>', 0, "infinite m//g on arrays (aelem)"; | |
1744 | ||
1745 | my %h; | |
1746 | $h{a} = $^X . '-'; | |
1747 | $h{a}=~ m/(.)/g; | |
1748 | cmp_ok pos($h{a}), '>', 0, "infinite m//g on hashes (helem)"; | |
e26a4975 | 1749 | } |
0aa395f8 NC |
1750 | |
1751 | SKIP: | |
1752 | { | |
1753 | my $got_dualvar; | |
1754 | eval 'use Scalar::Util "dualvar"; $got_dualvar++'; | |
1755 | skip "No Scalar::Util::dualvar" unless $got_dualvar; | |
1756 | my $a = Scalar::Util::dualvar(3, $^X); | |
1757 | my $b = $a + 5; | |
1758 | is ($b, 8, "Arithmetic on tainted dualvars works"); | |
1759 | } | |
f27977c3 MH |
1760 | |
1761 | # opening '|-' should not trigger $ENV{PATH} check | |
1762 | ||
1763 | { | |
1764 | SKIP: { | |
1765 | skip "fork() is not available", 3 unless $Config{'d_fork'}; | |
1fb83d06 SS |
1766 | skip "opening |- is not stable on threaded Open/MirBSD with taint", 3 |
1767 | if $Config{useithreads} and $Is_OpenBSD || $Is_MirBSD; | |
f27977c3 MH |
1768 | |
1769 | $ENV{'PATH'} = $TAINT; | |
1770 | local $SIG{'PIPE'} = 'IGNORE'; | |
1771 | eval { | |
1772 | my $pid = open my $pipe, '|-'; | |
1773 | if (!defined $pid) { | |
1774 | die "open failed: $!"; | |
1775 | } | |
1776 | if (!$pid) { | |
1777 | kill 'KILL', $$; # child suicide | |
1778 | } | |
1779 | close $pipe; | |
1780 | }; | |
c3197de1 NC |
1781 | unlike($@, qr/Insecure \$ENV/, 'fork triggers %ENV check'); |
1782 | is($@, '', 'pipe/fork/open/close failed'); | |
f27977c3 MH |
1783 | eval { |
1784 | open my $pipe, "|$Invoke_Perl -e 1"; | |
1785 | close $pipe; | |
1786 | }; | |
c3197de1 | 1787 | like($@, qr/Insecure \$ENV/, 'popen neglects %ENV check'); |
f27977c3 MH |
1788 | } |
1789 | } | |
5d121f7f RD |
1790 | |
1791 | { | |
1792 | package AUTOLOAD_TAINT; | |
1793 | sub AUTOLOAD { | |
1794 | our $AUTOLOAD; | |
1795 | return if $AUTOLOAD =~ /DESTROY/; | |
1796 | if ($AUTOLOAD =~ /untainted/) { | |
f37ea7f0 | 1797 | main::isnt_tainted($AUTOLOAD, '$AUTOLOAD can be untainted'); |
d40bf27b | 1798 | my $copy = $AUTOLOAD; |
f37ea7f0 | 1799 | main::isnt_tainted($copy, '$AUTOLOAD can be untainted'); |
5d121f7f | 1800 | } else { |
f37ea7f0 | 1801 | main::is_tainted($AUTOLOAD, '$AUTOLOAD can be tainted'); |
d40bf27b | 1802 | my $copy = $AUTOLOAD; |
f37ea7f0 | 1803 | main::is_tainted($copy, '$AUTOLOAD can be tainted'); |
5d121f7f RD |
1804 | } |
1805 | } | |
1806 | ||
1807 | package main; | |
1808 | my $o = bless [], 'AUTOLOAD_TAINT'; | |
d40bf27b | 1809 | $o->untainted; |
5d121f7f RD |
1810 | $o->$TAINT; |
1811 | $o->untainted; | |
1812 | } | |
1813 | ||
20ee07fb RGS |
1814 | { |
1815 | # tests for tainted format in s?printf | |
e06d98fb DM |
1816 | my $fmt = $TAINT . "# %s\n"; |
1817 | violates_taint(sub { printf($fmt, "foo") }, 'printf', | |
4e74b85b | 1818 | q/printf doesn't like tainted formats/); |
e06d98fb DM |
1819 | violates_taint(sub { printf($TAINT . "# %s\n", "foo") }, 'printf', |
1820 | q/printf doesn't like tainted format expressions/); | |
20ee07fb | 1821 | eval { printf("# %s\n", $TAINT . "foo") }; |
433f4d03 | 1822 | is($@, '', q/printf accepts other tainted args/); |
e06d98fb | 1823 | violates_taint(sub { sprintf($fmt, "foo") }, 'sprintf', |
4e74b85b | 1824 | q/sprintf doesn't like tainted formats/); |
e06d98fb DM |
1825 | violates_taint(sub { sprintf($TAINT . "# %s\n", "foo") }, 'sprintf', |
1826 | q/sprintf doesn't like tainted format expressions/); | |
20ee07fb | 1827 | eval { sprintf("# %s\n", $TAINT . "foo") }; |
433f4d03 | 1828 | is($@, '', q/sprintf accepts other tainted args/); |
20ee07fb | 1829 | } |
085bde85 NC |
1830 | |
1831 | { | |
1832 | # 40708 | |
1833 | my $n = 7e9; | |
1834 | 8e9 - $n; | |
1835 | ||
1836 | my $val = $n; | |
1837 | is ($val, '7000000000', 'Assignment to untainted variable'); | |
1838 | $val = $TAINT; | |
1839 | $val = $n; | |
1840 | is ($val, '7000000000', 'Assignment to tainted variable'); | |
1841 | } | |
5e500fc8 NC |
1842 | |
1843 | { | |
5e500fc8 NC |
1844 | my $val = 0; |
1845 | my $tainted = '1' . $TAINT; | |
1846 | eval '$val = eval $tainted;'; | |
1847 | is ($val, 0, "eval doesn't like tainted strings"); | |
1848 | like ($@, qr/^Insecure dependency in eval/); | |
1849 | ||
abb7fb96 | 1850 | # Rather nice code to get a tainted undef by from Rick Delaney |
22d7dfed NC |
1851 | open my $fh, "test.pl" or die $!; |
1852 | seek $fh, 0, 2 or die $!; | |
1853 | $tainted = <$fh>; | |
5e500fc8 NC |
1854 | |
1855 | eval 'eval $tainted'; | |
1856 | like ($@, qr/^Insecure dependency in eval/); | |
1857 | } | |
beeaa6fd | 1858 | |
d3706118 NC |
1859 | foreach my $ord (78, 163, 256) { |
1860 | # 47195 | |
1861 | my $line = 'A1' . $TAINT . chr $ord; | |
1862 | chop $line; | |
1863 | is($line, 'A1'); | |
1864 | $line =~ /(A\S*)/; | |
f37ea7f0 | 1865 | isnt_tainted($1, "\\S match with chr $ord"); |
d3706118 NC |
1866 | } |
1867 | ||
ec93b65f CS |
1868 | { |
1869 | # 59998 | |
1870 | sub cr { my $x = crypt($_[0], $_[1]); $x } | |
1871 | sub co { my $x = ~$_[0]; $x } | |
1872 | my ($a, $b); | |
1873 | $a = cr('hello', 'foo' . $TAINT); | |
1874 | $b = cr('hello', 'foo'); | |
f37ea7f0 NC |
1875 | is_tainted($a, "tainted crypt"); |
1876 | isnt_tainted($b, "untainted crypt"); | |
ec93b65f CS |
1877 | $a = co('foo' . $TAINT); |
1878 | $b = co('foo'); | |
f37ea7f0 NC |
1879 | is_tainted($a, "tainted complement"); |
1880 | isnt_tainted($b, "untainted complement"); | |
ec93b65f CS |
1881 | } |
1882 | ||
302c0c93 NC |
1883 | { |
1884 | my @data = qw(bonk zam zlonk qunckkk); | |
1885 | # Clearly some sort of usenet bang-path | |
1886 | my $string = $TAINT . join "!", @data; | |
1887 | ||
f37ea7f0 | 1888 | is_tainted($string, "tainted data"); |
302c0c93 NC |
1889 | |
1890 | my @got = split /!|,/, $string; | |
1891 | ||
1892 | # each @got would be useful here, but I want the test for earlier perls | |
1893 | for my $i (0 .. $#data) { | |
f37ea7f0 | 1894 | is_tainted($got[$i], "tainted result $i"); |
302c0c93 NC |
1895 | is($got[$i], $data[$i], "correct content $i"); |
1896 | } | |
1897 | ||
f37ea7f0 | 1898 | is_tainted($string, "still tainted data"); |
302c0c93 NC |
1899 | |
1900 | my @got = split /[!,]/, $string; | |
1901 | ||
1902 | # each @got would be useful here, but I want the test for earlier perls | |
1903 | for my $i (0 .. $#data) { | |
f37ea7f0 | 1904 | is_tainted($got[$i], "tainted result $i"); |
302c0c93 NC |
1905 | is($got[$i], $data[$i], "correct content $i"); |
1906 | } | |
1907 | ||
f37ea7f0 | 1908 | is_tainted($string, "still tainted data"); |
302c0c93 NC |
1909 | |
1910 | my @got = split /!/, $string; | |
1911 | ||
1912 | # each @got would be useful here, but I want the test for earlier perls | |
1913 | for my $i (0 .. $#data) { | |
f37ea7f0 | 1914 | is_tainted($got[$i], "tainted result $i"); |
302c0c93 NC |
1915 | is($got[$i], $data[$i], "correct content $i"); |
1916 | } | |
1917 | } | |
1918 | ||
3c4fb04a RB |
1919 | # Bug RT #52552 - broken by change at git commit id f337b08 |
1920 | { | |
1921 | my $x = $TAINT. q{print "Hello world\n"}; | |
1922 | my $y = pack "a*", $x; | |
f37ea7f0 | 1923 | is_tainted($y, "pack a* preserves tainting"); |
3c4fb04a RB |
1924 | |
1925 | my $z = pack "A*", q{print "Hello world\n"}.$TAINT; | |
f37ea7f0 | 1926 | is_tainted($z, "pack A* preserves tainting"); |
3c4fb04a RB |
1927 | |
1928 | my $zz = pack "a*a*", q{print "Hello world\n"}, $TAINT; | |
f37ea7f0 | 1929 | is_tainted($zz, "pack a*a* preserves tainting"); |
3c4fb04a RB |
1930 | } |
1931 | ||
0097b436 DM |
1932 | # Bug RT #61976 tainted $! would show numeric rather than string value |
1933 | ||
1934 | { | |
1935 | my $tainted_path = substr($^X,0,0) . "/no/such/file"; | |
1936 | my $err; | |
1937 | # $! is used in a tainted expression, so gets tainted | |
1938 | open my $fh, $tainted_path or $err= "$!"; | |
1939 | unlike($err, qr/^\d+$/, 'tainted $!'); | |
1940 | } | |
1941 | ||
b112cff9 DM |
1942 | { |
1943 | # #6758: tainted values become untainted in tied hashes | |
1944 | # (also applies to other value magic such as pos) | |
1945 | ||
1946 | ||
1947 | package P6758; | |
1948 | ||
1949 | sub TIEHASH { bless {} } | |
1950 | sub TIEARRAY { bless {} } | |
1951 | ||
1952 | my $i = 0; | |
1953 | ||
1954 | sub STORE { | |
f37ea7f0 NC |
1955 | main::is_tainted($_[1], "tied arg1 tainted"); |
1956 | main::is_tainted($_[2], "tied arg2 tainted"); | |
b112cff9 DM |
1957 | $i++; |
1958 | } | |
1959 | ||
1960 | package main; | |
1961 | ||
1962 | my ($k,$v) = qw(1111 val); | |
1963 | taint_these($k,$v); | |
1964 | tie my @array, 'P6758'; | |
1965 | tie my %hash , 'P6758'; | |
1966 | $array[$k] = $v; | |
1967 | $hash{$k} = $v; | |
1968 | ok $i == 2, "tied STORE called correct number of times"; | |
1969 | } | |
1970 | ||
3e6bd4bf DM |
1971 | # Bug RT #45167 the return value of sprintf sometimes wasn't tainted |
1972 | # when the args were tainted. This only occured on the first use of | |
1973 | # sprintf; after that, its TARG has taint magic attached, so setmagic | |
1974 | # at the end works. That's why there are multiple sprintf's below, rather | |
93f09d7b | 1975 | # than just one wrapped in an inner loop. Also, any plaintext between |
3e6bd4bf DM |
1976 | # fprmat entires would correctly cause tainting to get set. so test with |
1977 | # "%s%s" rather than eg "%s %s". | |
1978 | ||
1979 | { | |
1980 | for my $var1 ($TAINT, "123") { | |
1981 | for my $var2 ($TAINT0, "456") { | |
8e29defb NC |
1982 | is( tainted(sprintf '%s', $var1, $var2), tainted($var1), |
1983 | "sprintf '%s', '$var1', '$var2'" ); | |
1984 | is( tainted(sprintf ' %s', $var1, $var2), tainted($var1), | |
1985 | "sprintf ' %s', '$var1', '$var2'" ); | |
1986 | is( tainted(sprintf '%s%s', $var1, $var2), | |
1987 | tainted($var1) || tainted($var2), | |
1988 | "sprintf '%s%s', '$var1', '$var2'" ); | |
3e6bd4bf DM |
1989 | } |
1990 | } | |
1991 | } | |
1992 | ||
1993 | ||
447ee134 DM |
1994 | # Bug RT #67962: old tainted $1 gets treated as tainted |
1995 | # in next untainted # match | |
1996 | ||
1997 | { | |
1998 | use re 'taint'; | |
1999 | "abc".$TAINT =~ /(.*)/; # make $1 tainted | |
f37ea7f0 | 2000 | is_tainted($1, '$1 should be tainted'); |
447ee134 DM |
2001 | |
2002 | my $untainted = "abcdef"; | |
f37ea7f0 | 2003 | isnt_tainted($untainted, '$untainted should be untainted'); |
447ee134 | 2004 | $untainted =~ s/(abc)/$1/; |
f37ea7f0 | 2005 | isnt_tainted($untainted, '$untainted should still be untainted'); |
447ee134 | 2006 | $untainted =~ s/(abc)/x$1/; |
f37ea7f0 | 2007 | isnt_tainted($untainted, '$untainted should yet still be untainted'); |
447ee134 DM |
2008 | } |
2009 | ||
7e6078c6 | 2010 | { |
d4456f89 JD |
2011 | # On Windows we can't spawn a fresh Perl interpreter unless at |
2012 | # least the Windows system directory (usually C:\Windows\System32) | |
2013 | # is still on the PATH. There is however no way to determine the | |
2014 | # actual path on the current system without loading the Win32 | |
2015 | # module, so we just restore the original $ENV{PATH} here. | |
2016 | local $ENV{PATH} = $ENV{PATH}; | |
2017 | $ENV{PATH} = $old_env_path if $Is_MSWin32; | |
2018 | ||
7e6078c6 NT |
2019 | fresh_perl_is(<<'end', "ok", { switches => [ '-T' ] }, |
2020 | $TAINT = substr($^X, 0, 0); | |
00cb33d6 FC |
2021 | formline('@'.('<'x("2000".$TAINT)).' | @*', 'hallo', 'welt'); |
2022 | print "ok"; | |
7e6078c6 NT |
2023 | end |
2024 | "formline survives a tainted dynamic picture"); | |
2025 | } | |
0097b436 | 2026 | |
125b9982 | 2027 | { |
f37ea7f0 | 2028 | isnt_tainted($^A, "format accumulator not tainted yet"); |
99e6ea26 | 2029 | formline('@ | @*', 'hallo' . $TAINT, 'welt'); |
f37ea7f0 | 2030 | is_tainted($^A, "tainted formline argument makes a tainted accumulator"); |
99e6ea26 | 2031 | $^A = ""; |
f37ea7f0 | 2032 | isnt_tainted($^A, "accumulator can be explicitly untainted"); |
99e6ea26 | 2033 | formline('@' .('<'*5) . ' | @*', 'hallo', 'welt'); |
f37ea7f0 | 2034 | isnt_tainted($^A, "accumulator still untainted"); |
99e6ea26 | 2035 | $^A = "" . $TAINT; |
f37ea7f0 | 2036 | is_tainted($^A, "accumulator can be explicitly tainted"); |
99e6ea26 | 2037 | formline('@' .('<'*5) . ' | @*', 'hallo', 'welt'); |
f37ea7f0 | 2038 | is_tainted($^A, "accumulator still tainted"); |
99e6ea26 | 2039 | $^A = ""; |
f37ea7f0 | 2040 | isnt_tainted($^A, "accumulator untainted again"); |
99e6ea26 | 2041 | formline('@' .('<'*5) . ' | @*', 'hallo', 'welt'); |
f37ea7f0 | 2042 | isnt_tainted($^A, "accumulator still untainted"); |
99e6ea26 | 2043 | formline('@' .('<'*(5+$TAINT0)) . ' | @*', 'hallo', 'welt'); |
125b9982 NT |
2044 | TODO: { |
2045 | local $::TODO = "get magic handled too late?"; | |
f37ea7f0 | 2046 | is_tainted($^A, "the accumulator should be tainted already"); |
125b9982 | 2047 | } |
f37ea7f0 | 2048 | is_tainted($^A, "tainted formline picture makes a tainted accumulator"); |
99e6ea26 NT |
2049 | } |
2050 | ||
929fffa4 KW |
2051 | { # Bug #80610 |
2052 | "Constant(1)" =~ / ^ ([a-z_]\w*) (?: [(] (.*) [)] )? $ /xi; | |
2053 | my $a = $1; | |
2054 | my $b = $2; | |
f37ea7f0 NC |
2055 | isnt_tainted($a, "regex optimization of single char /[]/i doesn't taint"); |
2056 | isnt_tainted($b, "regex optimization of single char /[]/i doesn't taint"); | |
929fffa4 KW |
2057 | } |
2058 | ||
8985fe98 DM |
2059 | { |
2060 | # RT 81230: tainted value during FETCH created extra ref to tied obj | |
2061 | ||
2062 | package P81230; | |
2063 | use warnings; | |
2064 | ||
2065 | my %h; | |
2066 | ||
2067 | sub TIEHASH { | |
2068 | my $x = $^X; # tainted | |
2069 | bless \$x; | |
2070 | } | |
2071 | sub FETCH { my $x = $_[0]; $$x . "" } | |
2072 | ||
2073 | tie %h, 'P81230'; | |
2074 | ||
2075 | my $w = ""; | |
2076 | local $SIG{__WARN__} = sub { $w .= "@_" }; | |
2077 | ||
2078 | untie %h if $h{"k"}; | |
2079 | ||
2080 | ::is($w, "", "RT 81230"); | |
2081 | } | |
2082 | ||
5a909b52 GG |
2083 | { |
2084 | # Compiling a subroutine inside a tainted expression does not make the | |
2085 | # constant folded values tainted. | |
2086 | my $x = sub { "x" . "y" }; | |
2087 | my $y = $ENV{PATH} . $x->(); # Compile $x inside a tainted expression | |
2088 | my $z = $x->(); | |
f37ea7f0 | 2089 | isnt_tainted($z, "Constants folded value not tainted"); |
5a909b52 | 2090 | } |
8985fe98 | 2091 | |
9274aefd DM |
2092 | { |
2093 | # now that regexes are first class SVs, make sure that they themselves | |
2094 | # as well as references to them are tainted | |
2095 | ||
2096 | my $rr = qr/(.)$TAINT/; | |
2097 | my $r = $$rr; # bare REGEX | |
2098 | my $s ="abc"; | |
2099 | ok($s =~ s/$r/x/, "match bare regex"); | |
f37ea7f0 | 2100 | is_tainted($s, "match bare regex taint"); |
9274aefd DM |
2101 | is($s, 'xbc', "match bare regex taint value"); |
2102 | } | |
2103 | ||
0e9be77f DM |
2104 | { |
2105 | # [perl #82616] security Issues with user-defined \p{} properties | |
2106 | # A using a tainted user-defined property should croak | |
2107 | ||
2108 | sub IsA { sprintf "%02x", ord("A") } | |
2109 | ||
2110 | my $prop = "IsA"; | |
2111 | ok("A" =~ /\p{$prop}/, "user-defined property: non-tainted case"); | |
2112 | $prop = "IsA$TAINT"; | |
2113 | eval { "A" =~ /\p{$prop}/}; | |
2114 | like($@, qr/Insecure user-defined property \\p{main::IsA}/, | |
2115 | "user-defined property: tainted case"); | |
2116 | } | |
2117 | ||
539689e7 FC |
2118 | { |
2119 | # [perl #87336] lc/uc(first) failing to taint the returned string | |
2120 | my $source = "foo$TAINT"; | |
2121 | my $dest = lc $source; | |
2122 | is_tainted $dest, "lc(tainted) taints its return value"; | |
2123 | $dest = lcfirst $source; | |
2124 | is_tainted $dest, "lcfirst(tainted) taints its return value"; | |
2125 | $dest = uc $source; | |
2126 | is_tainted $dest, "uc(tainted) taints its return value"; | |
2127 | $dest = ucfirst $source; | |
2128 | is_tainted $dest, "ucfirst(tainted) taints its return value"; | |
2129 | } | |
2130 | ||
fa22d357 VP |
2131 | { |
2132 | # Taintedness of values returned from given() | |
2133 | use feature 'switch'; | |
2134 | ||
2135 | my @descriptions = ('when', 'given end', 'default'); | |
2136 | ||
2137 | for (qw<x y z>) { | |
2138 | my $letter = "$_$TAINT"; | |
2139 | ||
2140 | my $desc = "tainted value returned from " . shift(@descriptions); | |
2141 | ||
2142 | my $res = do { | |
2143 | given ($_) { | |
2144 | when ('x') { $letter } | |
2145 | when ('y') { goto leavegiven } | |
2146 | default { $letter } | |
2147 | leavegiven: $letter | |
2148 | } | |
2149 | }; | |
2150 | is $res, $letter, "$desc is correct"; | |
2151 | is_tainted $res, "$desc stays tainted"; | |
2152 | } | |
2153 | } | |
2154 | ||
0d1104b4 NT |
2155 | |
2156 | # tainted constants and index() | |
2157 | # RT 64804; http://bugs.debian.org/291450 | |
2158 | { | |
2159 | ok(tainted $old_env_path, "initial taintedness"); | |
2160 | BEGIN { no strict 'refs'; my $v = $old_env_path; *{"::C"} = sub () { $v }; } | |
2161 | ok(tainted C, "constant is tainted properly"); | |
2162 | ok(!tainted "", "tainting not broken yet"); | |
2163 | index(undef, C); | |
0d1104b4 NT |
2164 | ok(!tainted "", "tainting still works after index() of the constant"); |
2165 | } | |
2166 | ||
be88a5c3 FC |
2167 | # Tainted values with smartmatch |
2168 | # [perl #93590] S_do_smartmatch stealing its own string buffers | |
2169 | ok "M$TAINT" ~~ ['m', 'M'], '$tainted ~~ ["whatever", "match"]'; | |
2170 | ok !("M$TAINT" ~~ ['m', undef]), '$tainted ~~ ["whatever", undef]'; | |
0d1104b4 NT |
2171 | |
2172 | ||
beeaa6fd NC |
2173 | # This may bomb out with the alarm signal so keep it last |
2174 | SKIP: { | |
2175 | skip "No alarm()" unless $Config{d_alarm}; | |
2176 | # Test from RT #41831] | |
2177 | # [PATCH] Bug & fix: hang when using study + taint mode (perl 5.6.1, 5.8.x) | |
2178 | ||
2179 | my $DATA = <<'END' . $TAINT; | |
2180 | line1 is here | |
2181 | line2 is here | |
2182 | line3 is here | |
2183 | line4 is here | |
2184 | ||
2185 | END | |
2186 | ||
2187 | #study $DATA; | |
2188 | ||
2189 | ## don't set $SIG{ALRM}, since we'd never get to a user-level handler as | |
2190 | ## perl is stuck in a regexp infinite loop! | |
2191 | ||
2192 | alarm(10); | |
2193 | ||
2194 | if ($DATA =~ /^line2.*line4/m) { | |
2195 | fail("Should not be a match") | |
2196 | } else { | |
2197 | pass("Match on tainted multiline data should fail promptly"); | |
2198 | } | |
2199 | ||
2200 | alarm(0); | |
2201 | } | |
2202 | __END__ | |
2203 | # Keep the previous test last |