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