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