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'; |
1e422769 | 13 | } |
14 | ||
15 | use strict; | |
16 | use Config; | |
dc459aad | 17 | use File::Spec::Functions; |
1e422769 | 18 | |
09f04786 | 19 | BEGIN { require './test.pl'; } |
f37ea7f0 | 20 | plan tests => 706; |
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 | |
100 | sub any_tainted (@) { | |
101 | not eval { join("",@_), kill 0; 1 }; | |
102 | } | |
103 | sub tainted ($) { | |
104 | any_tainted @_; | |
105 | } | |
106 | sub all_tainted (@) { | |
107 | for (@_) { return 0 unless tainted $_ } | |
108 | 1; | |
109 | } | |
110 | ||
f37ea7f0 NC |
111 | sub is_tainted { |
112 | my $thing = shift; | |
113 | local $::Level = $::Level + 1; | |
114 | ok(any_tainted($thing), @_); | |
115 | } | |
116 | ||
117 | sub isnt_tainted { | |
118 | my $thing = shift; | |
119 | local $::Level = $::Level + 1; | |
120 | ok(!any_tainted($thing), @_); | |
121 | } | |
122 | ||
1e422769 | 123 | # We need an external program to call. |
7b903762 | 124 | my $ECHO = ($Is_MSWin32 ? ".\\echo$$" : ($Is_NetWare ? "echo$$" : "./echo$$")); |
1e422769 | 125 | END { unlink $ECHO } |
126 | open PROG, "> $ECHO" or die "Can't create $ECHO: $!"; | |
127 | print PROG 'print "@ARGV\n"', "\n"; | |
128 | close PROG; | |
129 | my $echo = "$Invoke_Perl $ECHO"; | |
130 | ||
dc459aad JH |
131 | my $TEST = catfile(curdir(), 'TEST'); |
132 | ||
1e422769 | 133 | # First, let's make sure that Perl is checking the dangerous |
134 | # environment variables. Maybe they aren't set yet, so we'll | |
135 | # taint them ourselves. | |
136 | { | |
137 | $ENV{'DCL$PATH'} = '' if $Is_VMS; | |
138 | ||
f68313a1 SH |
139 | if ($Is_MSWin32 && $Config{ccname} =~ /bcc32/ && ! -f 'cc3250mt.dll') { |
140 | my $bcc_dir; | |
141 | foreach my $dir (split /$Config{path_sep}/, $ENV{PATH}) { | |
142 | if (-f "$dir/cc3250mt.dll") { | |
143 | $bcc_dir = $dir and last; | |
144 | } | |
145 | } | |
146 | if (defined $bcc_dir) { | |
147 | require File::Copy; | |
148 | File::Copy::copy("$bcc_dir/cc3250mt.dll", '.') or | |
149 | die "$0: failed to copy cc3250mt.dll: $!\n"; | |
150 | eval q{ | |
151 | END { unlink "cc3250mt.dll" } | |
152 | }; | |
153 | } | |
154 | } | |
e59c8b07 | 155 | $ENV{PATH} = ($Is_Cygwin) ? '/usr/bin' : ''; |
c90c0ff4 | 156 | delete @ENV{@MoreEnv}; |
7bac28a0 | 157 | $ENV{TERM} = 'dumb'; |
158 | ||
c3197de1 | 159 | is(eval { `$echo 1` }, "1\n"); |
09f04786 MS |
160 | |
161 | SKIP: { | |
162 | skip "Environment tainting tests skipped", 4 | |
7b903762 | 163 | if $Is_MSWin32 || $Is_NetWare || $Is_VMS || $Is_Dos; |
7bac28a0 | 164 | |
7bac28a0 | 165 | my @vars = ('PATH', @MoreEnv); |
166 | while (my $v = $vars[0]) { | |
167 | local $ENV{$v} = $TAINT; | |
168 | last if eval { `$echo 1` }; | |
169 | last unless $@ =~ /^Insecure \$ENV{$v}/; | |
170 | shift @vars; | |
171 | } | |
c3197de1 | 172 | is("@vars", ""); |
c90c0ff4 | 173 | |
174 | # tainted $TERM is unsafe only if it contains metachars | |
175 | local $ENV{TERM}; | |
176 | $ENV{TERM} = 'e=mc2'; | |
c3197de1 | 177 | is(eval { `$echo 1` }, "1\n"); |
c90c0ff4 | 178 | $ENV{TERM} = 'e=mc2' . $TAINT; |
c3197de1 NC |
179 | is(eval { `$echo 1` }, undef); |
180 | like($@, qr/^Insecure \$ENV{TERM}/); | |
5aabfad6 | 181 | } |
7bac28a0 | 182 | |
9607fc9c | 183 | my $tmp; |
2986a63f | 184 | if ($^O eq 'os2' || $^O eq 'amigaos' || $Is_MSWin32 || $Is_NetWare || $Is_Dos) { |
48c036b1 GS |
185 | print "# all directories are writeable\n"; |
186 | } | |
187 | else { | |
9607fc9c | 188 | $tmp = (grep { defined and -d and (stat _)[2] & 2 } |
099f76bb | 189 | qw(sys$scratch /tmp /var/tmp /usr/tmp), |
9607fc9c | 190 | @ENV{qw(TMP TEMP)})[0] |
191 | or print "# can't find world-writeable directory to test PATH\n"; | |
192 | } | |
193 | ||
09f04786 MS |
194 | SKIP: { |
195 | skip "all directories are writeable", 2 unless $tmp; | |
196 | ||
7bac28a0 | 197 | local $ENV{PATH} = $tmp; |
c3197de1 NC |
198 | is(eval { `$echo 1` }, undef); |
199 | like($@, qr/^Insecure directory in \$ENV{PATH}/); | |
1e422769 | 200 | } |
201 | ||
09f04786 MS |
202 | SKIP: { |
203 | skip "This is not VMS", 4 unless $Is_VMS; | |
204 | ||
1e422769 | 205 | $ENV{'DCL$PATH'} = $TAINT; |
c3197de1 NC |
206 | is(eval { `$echo 1` }, ''); |
207 | like($@, qr/^Insecure \$ENV{DCL\$PATH}/); | |
09f04786 MS |
208 | SKIP: { |
209 | skip q[can't find world-writeable directory to test DCL$PATH], 2 | |
25fb98c0 | 210 | unless $tmp; |
09f04786 | 211 | |
9607fc9c | 212 | $ENV{'DCL$PATH'} = $tmp; |
c3197de1 NC |
213 | is(eval { `$echo 1` }, ''); |
214 | like($@, qr/^Insecure directory in \$ENV{DCL\$PATH}/); | |
9607fc9c | 215 | } |
1e422769 | 216 | $ENV{'DCL$PATH'} = ''; |
217 | } | |
1e422769 | 218 | } |
219 | ||
220 | # Let's see that we can taint and untaint as needed. | |
221 | { | |
222 | my $foo = $TAINT; | |
f37ea7f0 | 223 | is_tainted($foo); |
9607fc9c | 224 | |
225 | # That was a sanity check. If it failed, stop the insanity! | |
226 | die "Taint checks don't seem to be enabled" unless tainted $foo; | |
1e422769 | 227 | |
228 | $foo = "foo"; | |
f37ea7f0 | 229 | isnt_tainted($foo); |
1e422769 | 230 | |
231 | taint_these($foo); | |
f37ea7f0 | 232 | is_tainted($foo); |
1e422769 | 233 | |
234 | my @list = 1..10; | |
c3197de1 | 235 | ok(not any_tainted @list); |
1e422769 | 236 | taint_these @list[1,3,5,7,9]; |
c3197de1 NC |
237 | ok(any_tainted @list); |
238 | ok(all_tainted @list[1,3,5,7,9]); | |
239 | ok(not any_tainted @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(); |
1e422769 | 971 | open PROG, "> $arg" or die "Can't create $arg: $!"; |
972 | print PROG q{ | |
973 | eval { join('', @ARGV), kill 0 }; | |
974 | exit 0 if $@ =~ /^Insecure dependency/; | |
975 | print "# Oops: \$@ was [$@]\n"; | |
976 | exit 1; | |
977 | }; | |
978 | close PROG; | |
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 | { | |
c3197de1 | 986 | ok(open FILE, $TEST) or diag("Couldn't open '$TEST': $!"); |
1e422769 | 987 | |
988 | my $block; | |
989 | sysread(FILE, $block, 100); | |
9607fc9c | 990 | my $line = <FILE>; |
1e422769 | 991 | close FILE; |
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 | { | |
c3197de1 | 1004 | ok(all_tainted $^X, $0); |
1e422769 | 1005 | } |
1006 | ||
1007 | # Results of matching should all be untainted | |
1008 | { | |
1009 | my $foo = "abcdefghi" . $TAINT; | |
f37ea7f0 | 1010 | is_tainted($foo); |
1e422769 | 1011 | |
1012 | $foo =~ /def/; | |
c3197de1 | 1013 | ok(not any_tainted $`, $&, $'); |
1e422769 | 1014 | |
1015 | $foo =~ /(...)(...)(...)/; | |
c3197de1 | 1016 | ok(not any_tainted $1, $2, $3, $+); |
1e422769 | 1017 | |
1018 | my @bar = $foo =~ /(...)(...)(...)/; | |
c3197de1 | 1019 | ok(not any_tainted @bar); |
1e422769 | 1020 | |
f37ea7f0 | 1021 | is_tainted($foo); # $foo should still be tainted! |
c3197de1 | 1022 | is($foo, "abcdefghi"); |
1e422769 | 1023 | } |
1024 | ||
1025 | # Operations which affect files can't use tainted data. | |
1026 | { | |
c3197de1 NC |
1027 | is(eval { chmod 0, $TAINT }, undef, 'chmod'); |
1028 | like($@, qr/^Insecure dependency/); | |
1e422769 | 1029 | |
e2b4a08c NC |
1030 | SKIP: { |
1031 | skip "truncate() is not available", 2 unless $Config{d_truncate}; | |
1032 | ||
c3197de1 NC |
1033 | is(eval { truncate 'NoSuChFiLe', $TAINT0 }, undef, 'truncate'); |
1034 | like($@, qr/^Insecure dependency/); | |
e2b4a08c | 1035 | } |
1e422769 | 1036 | |
c3197de1 NC |
1037 | is(eval { rename '', $TAINT }, undef, 'rename'); |
1038 | like($@, qr/^Insecure dependency/); | |
1e422769 | 1039 | |
c3197de1 NC |
1040 | is(eval { unlink $TAINT }, undef, 'unlink'); |
1041 | like($@, qr/^Insecure dependency/); | |
9607fc9c | 1042 | |
c3197de1 NC |
1043 | is(eval { utime $TAINT }, undef, 'utime'); |
1044 | like($@, qr/^Insecure dependency/); | |
48c036b1 | 1045 | |
09f04786 MS |
1046 | SKIP: { |
1047 | skip "chown() is not available", 2 unless $Config{d_chown}; | |
1e422769 | 1048 | |
c3197de1 NC |
1049 | is(eval { chown -1, -1, $TAINT }, undef, 'chown'); |
1050 | like($@, qr/^Insecure dependency/); | |
1e422769 | 1051 | } |
1052 | ||
09f04786 MS |
1053 | SKIP: { |
1054 | skip "link() is not available", 2 unless $Config{d_link}; | |
1055 | ||
c3197de1 NC |
1056 | is(eval { link $TAINT, '' }, undef, 'link'); |
1057 | like($@, qr/^Insecure dependency/); | |
1e422769 | 1058 | } |
09f04786 MS |
1059 | |
1060 | SKIP: { | |
1061 | skip "symlink() is not available", 2 unless $Config{d_symlink}; | |
1062 | ||
c3197de1 NC |
1063 | is(eval { symlink $TAINT, '' }, undef, 'symlink'); |
1064 | like($@, qr/^Insecure dependency/); | |
1e422769 | 1065 | } |
1066 | } | |
1067 | ||
1068 | # Operations which affect directories can't use tainted data. | |
1069 | { | |
c3197de1 NC |
1070 | is(eval { mkdir "foo".$TAINT, 0755 . $TAINT0 }, undef, 'mkdir'); |
1071 | like($@, qr/^Insecure dependency/); | |
1e422769 | 1072 | |
c3197de1 NC |
1073 | is(eval { rmdir $TAINT }, undef, 'rmdir'); |
1074 | like($@, qr/^Insecure dependency/); | |
9607fc9c | 1075 | |
c3197de1 NC |
1076 | is(eval { chdir "foo".$TAINT }, undef, 'chdir'); |
1077 | like($@, qr/^Insecure dependency/); | |
48c036b1 | 1078 | |
09f04786 MS |
1079 | SKIP: { |
1080 | skip "chroot() is not available", 2 unless $Config{d_chroot}; | |
1081 | ||
c3197de1 NC |
1082 | is(eval { chroot $TAINT }, undef, 'chroot'); |
1083 | like($@, qr/^Insecure dependency/); | |
1e422769 | 1084 | } |
1085 | } | |
1086 | ||
1087 | # Some operations using files can't use tainted data. | |
1088 | { | |
1089 | my $foo = "imaginary library" . $TAINT; | |
c3197de1 NC |
1090 | is(eval { require $foo }, undef, 'require'); |
1091 | like($@, qr/^Insecure dependency/); | |
1e422769 | 1092 | |
1c25d394 | 1093 | my $filename = tempfile(); # NB: $filename isn't tainted! |
1e422769 | 1094 | $foo = $filename . $TAINT; |
1095 | unlink $filename; # in any case | |
1096 | ||
c3197de1 NC |
1097 | is(eval { open FOO, $foo }, undef, 'open for read'); |
1098 | is($@, ''); # NB: This should be allowed | |
9d116dd7 JH |
1099 | |
1100 | # Try first new style but allow also old style. | |
327ccce1 YST |
1101 | # We do not want the whole taint.t to fail |
1102 | # just because Errno possibly failing. | |
c3197de1 | 1103 | ok(eval('$!{ENOENT}') || |
61ae2fbf | 1104 | $! == 2 || # File not found |
c3197de1 | 1105 | ($Is_Dos && $! == 22)); |
1e422769 | 1106 | |
c3197de1 NC |
1107 | is(eval { open FOO, "> $foo" }, undef, 'open for write'); |
1108 | like($@, qr/^Insecure dependency/); | |
1e422769 | 1109 | } |
1110 | ||
1111 | # Commands to the system can't use tainted data | |
1112 | { | |
1113 | my $foo = $TAINT; | |
1114 | ||
09f04786 MS |
1115 | SKIP: { |
1116 | skip "open('|') is not available", 4 if $^O eq 'amigaos'; | |
1117 | ||
c3197de1 NC |
1118 | is(eval { open FOO, "| x$foo" }, undef, 'popen to'); |
1119 | like($@, qr/^Insecure dependency/); | |
1e422769 | 1120 | |
c3197de1 NC |
1121 | is(eval { open FOO, "x$foo |" }, undef, 'popen from'); |
1122 | like($@, qr/^Insecure dependency/); | |
48c036b1 | 1123 | } |
1e422769 | 1124 | |
c3197de1 NC |
1125 | is(eval { exec $TAINT }, undef, 'exec'); |
1126 | like($@, qr/^Insecure dependency/); | |
9607fc9c | 1127 | |
c3197de1 NC |
1128 | is(eval { system $TAINT }, undef, 'system'); |
1129 | like($@, qr/^Insecure dependency/); | |
48c036b1 | 1130 | |
1e422769 | 1131 | $foo = "*"; |
1132 | taint_these $foo; | |
1133 | ||
c3197de1 NC |
1134 | is(eval { `$echo 1$foo` }, undef, 'backticks'); |
1135 | like($@, qr/^Insecure dependency/); | |
1e422769 | 1136 | |
09f04786 MS |
1137 | SKIP: { |
1138 | # wildcard expansion doesn't invoke shell on VMS, so is safe | |
1139 | skip "This is not VMS", 2 unless $Is_VMS; | |
1140 | ||
c3197de1 NC |
1141 | isnt(join('', eval { glob $foo } ), '', 'globbing'); |
1142 | is($@, ''); | |
1e422769 | 1143 | } |
1144 | } | |
1145 | ||
1146 | # Operations which affect processes can't use tainted data. | |
1147 | { | |
c3197de1 NC |
1148 | is(eval { kill 0, $TAINT }, undef, 'kill'); |
1149 | like($@, qr/^Insecure dependency/); | |
1e422769 | 1150 | |
09f04786 MS |
1151 | SKIP: { |
1152 | skip "setpgrp() is not available", 2 unless $Config{d_setpgrp}; | |
1e422769 | 1153 | |
c3197de1 NC |
1154 | is(eval { setpgrp 0, $TAINT0 }, undef, 'setpgrp'); |
1155 | like($@, qr/^Insecure dependency/); | |
1e422769 | 1156 | } |
09f04786 MS |
1157 | |
1158 | SKIP: { | |
1159 | skip "setpriority() is not available", 2 unless $Config{d_setprior}; | |
1160 | ||
c3197de1 NC |
1161 | is(eval { setpriority 0, $TAINT0, $TAINT0 }, undef, 'setpriority'); |
1162 | like($@, qr/^Insecure dependency/); | |
1e422769 | 1163 | } |
1164 | } | |
1165 | ||
1166 | # Some miscellaneous operations can't use tainted data. | |
1167 | { | |
09f04786 MS |
1168 | SKIP: { |
1169 | skip "syscall() is not available", 2 unless $Config{d_syscall}; | |
1170 | ||
c3197de1 NC |
1171 | is(eval { syscall $TAINT }, undef, 'syscall'); |
1172 | like($@, qr/^Insecure dependency/); | |
1e422769 | 1173 | } |
1174 | ||
1175 | { | |
1176 | my $foo = "x" x 979; | |
1177 | taint_these $foo; | |
1178 | local *FOO; | |
1c25d394 | 1179 | my $temp = tempfile(); |
c3197de1 | 1180 | ok(open FOO, "> $temp") or diag("Couldn't open $temp for write: $!"); |
1e422769 | 1181 | |
c3197de1 NC |
1182 | is(eval { ioctl FOO, $TAINT0, $foo }, undef, 'ioctl'); |
1183 | like($@, qr/^Insecure dependency/); | |
1e422769 | 1184 | |
09f04786 MS |
1185 | SKIP: { |
1186 | skip "fcntl() is not available", 2 unless $Config{d_fcntl}; | |
1187 | ||
c3197de1 NC |
1188 | is(eval { fcntl FOO, $TAINT0, $foo }, undef, 'fcntl'); |
1189 | like($@, qr/^Insecure dependency/); | |
1e422769 | 1190 | } |
1191 | ||
1192 | close FOO; | |
1193 | } | |
1194 | } | |
1195 | ||
9607fc9c | 1196 | # Some tests involving references |
1e422769 | 1197 | { |
1198 | my $foo = 'abc' . $TAINT; | |
1199 | my $fooref = \$foo; | |
f37ea7f0 NC |
1200 | isnt_tainted($fooref); |
1201 | is_tainted($$fooref); | |
1202 | is_tainted($foo); | |
1e422769 | 1203 | } |
54310121 | 1204 | |
1205 | # Some tests involving assignment | |
1206 | { | |
1207 | my $foo = $TAINT0; | |
1208 | my $bar = $foo; | |
c3197de1 | 1209 | ok(all_tainted $foo, $bar); |
f37ea7f0 NC |
1210 | is_tainted($foo = $bar); |
1211 | is_tainted($bar = $bar); | |
1212 | is_tainted($bar += $bar); | |
1213 | is_tainted($bar -= $bar); | |
1214 | is_tainted($bar *= $bar); | |
1215 | is_tainted($bar++); | |
1216 | is_tainted($bar /= $bar); | |
1217 | is_tainted($bar += 0); | |
1218 | is_tainted($bar -= 2); | |
1219 | is_tainted($bar *= -1); | |
1220 | is_tainted($bar /= 1); | |
1221 | is_tainted($bar--); | |
c3197de1 | 1222 | is($bar, 0); |
54310121 | 1223 | } |
a1f49e72 CS |
1224 | |
1225 | # Test assignment and return of lists | |
1226 | { | |
1227 | my @foo = ("A", "tainted" . $TAINT, "B"); | |
f37ea7f0 NC |
1228 | isnt_tainted($foo[0]); |
1229 | is_tainted( $foo[1]); | |
1230 | isnt_tainted($foo[2]); | |
a1f49e72 | 1231 | my @bar = @foo; |
f37ea7f0 NC |
1232 | isnt_tainted($bar[0]); |
1233 | is_tainted( $bar[1]); | |
1234 | isnt_tainted($bar[2]); | |
a1f49e72 | 1235 | my @baz = eval { "A", "tainted" . $TAINT, "B" }; |
f37ea7f0 NC |
1236 | isnt_tainted($baz[0]); |
1237 | is_tainted( $baz[1]); | |
1238 | isnt_tainted($baz[2]); | |
a1f49e72 | 1239 | my @plugh = eval q[ "A", "tainted" . $TAINT, "B" ]; |
f37ea7f0 NC |
1240 | isnt_tainted($plugh[0]); |
1241 | is_tainted( $plugh[1]); | |
1242 | isnt_tainted($plugh[2]); | |
a1f49e72 | 1243 | my $nautilus = sub { "A", "tainted" . $TAINT, "B" }; |
f37ea7f0 NC |
1244 | isnt_tainted(((&$nautilus)[0])); |
1245 | is_tainted( ((&$nautilus)[1])); | |
1246 | isnt_tainted(((&$nautilus)[2])); | |
a1f49e72 | 1247 | my @xyzzy = &$nautilus; |
f37ea7f0 NC |
1248 | isnt_tainted($xyzzy[0]); |
1249 | is_tainted( $xyzzy[1]); | |
1250 | isnt_tainted($xyzzy[2]); | |
a1f49e72 | 1251 | my $red_october = sub { return "A", "tainted" . $TAINT, "B" }; |
f37ea7f0 NC |
1252 | isnt_tainted(((&$red_october)[0])); |
1253 | is_tainted( ((&$red_october)[1])); | |
1254 | isnt_tainted(((&$red_october)[2])); | |
a1f49e72 | 1255 | my @corge = &$red_october; |
f37ea7f0 NC |
1256 | isnt_tainted($corge[0]); |
1257 | is_tainted( $corge[1]); | |
1258 | isnt_tainted($corge[2]); | |
a1f49e72 | 1259 | } |
fb73857a | 1260 | |
1261 | # Test for system/library calls returning string data of dubious origin. | |
1262 | { | |
1263 | # No reliable %Config check for getpw* | |
09f04786 | 1264 | SKIP: { |
f37ea7f0 | 1265 | skip "getpwent() is not available", 9 unless |
09f04786 MS |
1266 | eval { setpwent(); getpwent() }; |
1267 | ||
fb73857a | 1268 | setpwent(); |
1269 | my @getpwent = getpwent(); | |
1270 | die "getpwent: $!\n" unless (@getpwent); | |
f37ea7f0 NC |
1271 | isnt_tainted($getpwent[0]); |
1272 | is_tainted($getpwent[1]); | |
1273 | isnt_tainted($getpwent[2]); | |
1274 | isnt_tainted($getpwent[3]); | |
1275 | isnt_tainted($getpwent[4]); | |
1276 | isnt_tainted($getpwent[5]); | |
1277 | is_tainted($getpwent[6], 'ge?cos'); | |
1278 | isnt_tainted($getpwent[7]); | |
1279 | is_tainted($getpwent[8], 'shell'); | |
fb73857a | 1280 | endpwent(); |
fb73857a | 1281 | } |
1282 | ||
09f04786 MS |
1283 | SKIP: { |
1284 | # pretty hard to imagine not | |
1285 | skip "readdir() is not available", 1 unless $Config{d_readdir}; | |
1286 | ||
fb73857a | 1287 | local(*D); |
1288 | opendir(D, "op") or die "opendir: $!\n"; | |
1289 | my $readdir = readdir(D); | |
f37ea7f0 | 1290 | is_tainted($readdir); |
09f04786 | 1291 | closedir(D); |
fb73857a | 1292 | } |
1293 | ||
09f04786 MS |
1294 | SKIP: { |
1295 | skip "readlink() or symlink() is not available" unless | |
1296 | $Config{d_readlink} && $Config{d_symlink}; | |
1297 | ||
fb73857a | 1298 | my $symlink = "sl$$"; |
1299 | unlink($symlink); | |
dc459aad JH |
1300 | my $sl = "/something/naughty"; |
1301 | # it has to be a real path on Mac OS | |
dc459aad | 1302 | symlink($sl, $symlink) or die "symlink: $!\n"; |
fb73857a | 1303 | my $readlink = readlink($symlink); |
f37ea7f0 | 1304 | is_tainted($readlink); |
fb73857a | 1305 | unlink($symlink); |
fb73857a | 1306 | } |
1307 | } | |
1308 | ||
1309 | # test bitwise ops (regression bug) | |
1310 | { | |
1311 | my $why = "y"; | |
1312 | my $j = "x" | $why; | |
f37ea7f0 | 1313 | isnt_tainted($j); |
fb73857a | 1314 | $why = $TAINT."y"; |
1315 | $j = "x" | $why; | |
f37ea7f0 | 1316 | is_tainted( $j); |
fb73857a | 1317 | } |
1318 | ||
48c036b1 GS |
1319 | # test target of substitution (regression bug) |
1320 | { | |
1321 | my $why = $TAINT."y"; | |
1322 | $why =~ s/y/z/; | |
f37ea7f0 | 1323 | is_tainted( $why); |
48c036b1 GS |
1324 | |
1325 | my $z = "[z]"; | |
1326 | $why =~ s/$z/zee/; | |
f37ea7f0 | 1327 | is_tainted( $why); |
48c036b1 GS |
1328 | |
1329 | $why =~ s/e/'-'.$$/ge; | |
f37ea7f0 | 1330 | is_tainted( $why); |
48c036b1 | 1331 | } |
d929ce6f | 1332 | |
09f04786 MS |
1333 | |
1334 | SKIP: { | |
1335 | skip "no IPC::SysV", 2 unless $ipcsysv; | |
1336 | ||
1337 | # test shmread | |
1338 | SKIP: { | |
1339 | skip "shm*() not available", 1 unless $Config{d_shm}; | |
1340 | ||
1341 | no strict 'subs'; | |
1342 | my $sent = "foobar"; | |
1343 | my $rcvd; | |
1344 | my $size = 2000; | |
1345 | my $id = shmget(IPC_PRIVATE, $size, S_IRWXU); | |
1346 | ||
1347 | if (defined $id) { | |
1348 | if (shmwrite($id, $sent, 0, 60)) { | |
1349 | if (shmread($id, $rcvd, 0, 60)) { | |
1350 | substr($rcvd, index($rcvd, "\0")) = ''; | |
1351 | } else { | |
1352 | warn "# shmread failed: $!\n"; | |
1353 | } | |
1354 | } else { | |
1355 | warn "# shmwrite failed: $!\n"; | |
1356 | } | |
1357 | shmctl($id, IPC_RMID, 0) or warn "# shmctl failed: $!\n"; | |
1358 | } else { | |
1359 | warn "# shmget failed: $!\n"; | |
1360 | } | |
1361 | ||
1362 | skip "SysV shared memory operation failed", 1 unless | |
1363 | $rcvd eq $sent; | |
1364 | ||
f37ea7f0 | 1365 | is_tainted($rcvd); |
c9f931b8 | 1366 | } |
c2e66d9e | 1367 | |
d929ce6f | 1368 | |
09f04786 MS |
1369 | # test msgrcv |
1370 | SKIP: { | |
1371 | skip "msg*() not available", 1 unless $Config{d_msg}; | |
41d6edb2 | 1372 | |
b9d1c439 | 1373 | no strict 'subs'; |
41d6edb2 JH |
1374 | my $id = msgget(IPC_PRIVATE, IPC_CREAT | S_IRWXU); |
1375 | ||
1376 | my $sent = "message"; | |
1377 | my $type_sent = 1234; | |
1378 | my $rcvd; | |
1379 | my $type_rcvd; | |
1380 | ||
1381 | if (defined $id) { | |
ddc3217d JH |
1382 | if (msgsnd($id, pack("l! a*", $type_sent, $sent), IPC_NOWAIT)) { |
1383 | if (msgrcv($id, $rcvd, 60, 0, IPC_NOWAIT)) { | |
41d6edb2 JH |
1384 | ($type_rcvd, $rcvd) = unpack("l! a*", $rcvd); |
1385 | } else { | |
ddc3217d | 1386 | warn "# msgrcv failed: $!\n"; |
41d6edb2 JH |
1387 | } |
1388 | } else { | |
ddc3217d | 1389 | warn "# msgsnd failed: $!\n"; |
41d6edb2 | 1390 | } |
c2e66d9e | 1391 | msgctl($id, IPC_RMID, 0) or warn "# msgctl failed: $!\n"; |
41d6edb2 JH |
1392 | } else { |
1393 | warn "# msgget failed\n"; | |
1394 | } | |
1395 | ||
09f04786 MS |
1396 | SKIP: { |
1397 | skip "SysV message queue operation failed", 1 | |
1398 | unless $rcvd eq $sent && $type_sent == $type_rcvd; | |
1399 | ||
f37ea7f0 | 1400 | is_tainted($rcvd); |
41d6edb2 | 1401 | } |
41d6edb2 JH |
1402 | } |
1403 | } | |
1404 | ||
3887d568 AP |
1405 | { |
1406 | # bug id 20001004.006 | |
1407 | ||
dc459aad | 1408 | open IN, $TEST or warn "$0: cannot read $TEST: $!" ; |
3887d568 AP |
1409 | local $/; |
1410 | my $a = <IN>; | |
1411 | my $b = <IN>; | |
09f04786 | 1412 | |
f37ea7f0 NC |
1413 | is_tainted($a); |
1414 | is_tainted($b); | |
1415 | is($b, undef); | |
09f04786 | 1416 | |
27c9684d | 1417 | close IN; |
3887d568 | 1418 | } |
27c9684d AP |
1419 | |
1420 | { | |
1421 | # bug id 20001004.007 | |
1422 | ||
dc459aad | 1423 | open IN, $TEST or warn "$0: cannot read $TEST: $!" ; |
27c9684d AP |
1424 | my $a = <IN>; |
1425 | ||
1426 | my $c = { a => 42, | |
1427 | b => $a }; | |
09f04786 | 1428 | |
f37ea7f0 NC |
1429 | isnt_tainted($c->{a}); |
1430 | is_tainted($c->{b}); | |
09f04786 | 1431 | |
27c9684d AP |
1432 | |
1433 | my $d = { a => $a, | |
1434 | b => 42 }; | |
f37ea7f0 NC |
1435 | is_tainted($d->{a}); |
1436 | isnt_tainted($d->{b}); | |
09f04786 | 1437 | |
27c9684d AP |
1438 | |
1439 | my $e = { a => 42, | |
1440 | b => { c => $a, d => 42 } }; | |
f37ea7f0 NC |
1441 | isnt_tainted($e->{a}); |
1442 | isnt_tainted($e->{b}); | |
1443 | is_tainted($e->{b}->{c}); | |
1444 | isnt_tainted($e->{b}->{d}); | |
27c9684d AP |
1445 | |
1446 | close IN; | |
1447 | } | |
1448 | ||
b94c04ac JH |
1449 | { |
1450 | # bug id 20010519.003 | |
1451 | ||
248c32c0 JH |
1452 | BEGIN { |
1453 | use vars qw($has_fcntl); | |
1454 | eval { require Fcntl; import Fcntl; }; | |
1455 | unless ($@) { | |
1456 | $has_fcntl = 1; | |
1457 | } | |
1458 | } | |
b94c04ac | 1459 | |
09f04786 MS |
1460 | SKIP: { |
1461 | skip "no Fcntl", 18 unless $has_fcntl; | |
1462 | ||
281a340f NC |
1463 | my $foo = tempfile(); |
1464 | my $evil = $foo . $TAINT; | |
248c32c0 JH |
1465 | |
1466 | eval { sysopen(my $ro, $evil, &O_RDONLY) }; | |
c3197de1 | 1467 | unlike($@, qr/^Insecure dependency/); |
248c32c0 JH |
1468 | |
1469 | eval { sysopen(my $wo, $evil, &O_WRONLY) }; | |
c3197de1 | 1470 | like($@, qr/^Insecure dependency/); |
248c32c0 JH |
1471 | |
1472 | eval { sysopen(my $rw, $evil, &O_RDWR) }; | |
c3197de1 | 1473 | like($@, qr/^Insecure dependency/); |
248c32c0 JH |
1474 | |
1475 | eval { sysopen(my $ap, $evil, &O_APPEND) }; | |
c3197de1 | 1476 | like($@, qr/^Insecure dependency/); |
248c32c0 JH |
1477 | |
1478 | eval { sysopen(my $cr, $evil, &O_CREAT) }; | |
c3197de1 | 1479 | like($@, qr/^Insecure dependency/); |
248c32c0 JH |
1480 | |
1481 | eval { sysopen(my $tr, $evil, &O_TRUNC) }; | |
c3197de1 | 1482 | like($@, qr/^Insecure dependency/); |
248c32c0 | 1483 | |
281a340f | 1484 | eval { sysopen(my $ro, $foo, &O_RDONLY | $TAINT0) }; |
c3197de1 | 1485 | unlike($@, qr/^Insecure dependency/); |
248c32c0 | 1486 | |
281a340f | 1487 | eval { sysopen(my $wo, $foo, &O_WRONLY | $TAINT0) }; |
c3197de1 | 1488 | like($@, qr/^Insecure dependency/); |
248c32c0 | 1489 | |
281a340f | 1490 | eval { sysopen(my $rw, $foo, &O_RDWR | $TAINT0) }; |
c3197de1 | 1491 | like($@, qr/^Insecure dependency/); |
248c32c0 | 1492 | |
281a340f | 1493 | eval { sysopen(my $ap, $foo, &O_APPEND | $TAINT0) }; |
c3197de1 | 1494 | like($@, qr/^Insecure dependency/); |
248c32c0 | 1495 | |
281a340f | 1496 | eval { sysopen(my $cr, $foo, &O_CREAT | $TAINT0) }; |
c3197de1 | 1497 | like($@, qr/^Insecure dependency/); |
248c32c0 | 1498 | |
281a340f | 1499 | eval { sysopen(my $tr, $foo, &O_TRUNC | $TAINT0) }; |
c3197de1 | 1500 | like($@, qr/^Insecure dependency/); |
248c32c0 | 1501 | |
281a340f | 1502 | eval { sysopen(my $ro, $foo, &O_RDONLY, $TAINT0) }; |
c3197de1 | 1503 | unlike($@, qr/^Insecure dependency/); |
248c32c0 | 1504 | |
281a340f | 1505 | eval { sysopen(my $wo, $foo, &O_WRONLY, $TAINT0) }; |
c3197de1 | 1506 | like($@, qr/^Insecure dependency/); |
248c32c0 | 1507 | |
281a340f | 1508 | eval { sysopen(my $rw, $foo, &O_RDWR, $TAINT0) }; |
c3197de1 | 1509 | like($@, qr/^Insecure dependency/); |
248c32c0 | 1510 | |
281a340f | 1511 | eval { sysopen(my $ap, $foo, &O_APPEND, $TAINT0) }; |
c3197de1 | 1512 | like($@, qr/^Insecure dependency/); |
248c32c0 | 1513 | |
281a340f | 1514 | eval { sysopen(my $cr, $foo, &O_CREAT, $TAINT0) }; |
c3197de1 | 1515 | like($@, qr/^Insecure dependency/); |
248c32c0 | 1516 | |
281a340f | 1517 | eval { sysopen(my $tr, $foo, &O_TRUNC, $TAINT0) }; |
c3197de1 | 1518 | like($@, qr/^Insecure dependency/); |
248c32c0 | 1519 | } |
b94c04ac JH |
1520 | } |
1521 | ||
65811bc3 JH |
1522 | { |
1523 | # bug 20010526.004 | |
1524 | ||
1525 | use warnings; | |
1526 | ||
09f04786 | 1527 | my $saw_warning = 0; |
c3197de1 | 1528 | local $SIG{__WARN__} = sub { ++$saw_warning }; |
65811bc3 JH |
1529 | |
1530 | sub fmi { | |
1531 | my $divnum = shift()/1; | |
1532 | sprintf("%1.1f\n", $divnum); | |
1533 | } | |
1534 | ||
1535 | fmi(21 . $TAINT); | |
1536 | fmi(37); | |
1537 | fmi(248); | |
1538 | ||
c3197de1 | 1539 | is($saw_warning, 0); |
65811bc3 JH |
1540 | } |
1541 | ||
9e1b5a4e A |
1542 | |
1543 | { | |
1544 | # Bug ID 20010730.010 | |
1545 | ||
1546 | my $i = 0; | |
1547 | ||
1548 | sub Tie::TIESCALAR { | |
1549 | my $class = shift; | |
1550 | my $arg = shift; | |
1551 | ||
1552 | bless \$arg => $class; | |
1553 | } | |
1554 | ||
1555 | sub Tie::FETCH { | |
1556 | $i ++; | |
1557 | ${$_ [0]} | |
1558 | } | |
1559 | ||
1560 | ||
1561 | package main; | |
1562 | ||
1563 | my $bar = "The Big Bright Green Pleasure Machine"; | |
1564 | taint_these $bar; | |
1565 | tie my ($foo), Tie => $bar; | |
1566 | ||
1567 | my $baz = $foo; | |
1568 | ||
09f04786 | 1569 | ok $i == 1; |
9e1b5a4e A |
1570 | } |
1571 | ||
8852b6d2 JH |
1572 | { |
1573 | # Check that all environment variables are tainted. | |
1574 | my @untainted; | |
1575 | while (my ($k, $v) = each %ENV) { | |
1576 | if (!tainted($v) && | |
eb25aaf6 HS |
1577 | # These we have explicitly untainted or set earlier. |
1578 | $k !~ /^(BASH_ENV|CDPATH|ENV|IFS|PATH|PERL_CORE|TEMP|TERM|TMP)$/) { | |
8852b6d2 JH |
1579 | push @untainted, "# '$k' = '$v'\n"; |
1580 | } | |
1581 | } | |
c3197de1 | 1582 | is("@untainted", ""); |
8852b6d2 | 1583 | } |
9e1b5a4e A |
1584 | |
1585 | ||
9aa05f58 | 1586 | ok( ${^TAINT} == 1, '$^TAINT is on' ); |
7c36658b MS |
1587 | |
1588 | eval { ${^TAINT} = 0 }; | |
1589 | ok( ${^TAINT}, '$^TAINT is not assignable' ); | |
1590 | ok( $@ =~ /^Modification of a read-only value attempted/, | |
c212f17f | 1591 | 'Assigning to ${^TAINT} fails' ); |
7c36658b | 1592 | |
e08e52cf AMS |
1593 | { |
1594 | # bug 20011111.105 | |
1595 | ||
1596 | my $re1 = qr/x$TAINT/; | |
f37ea7f0 | 1597 | is_tainted($re1); |
e08e52cf AMS |
1598 | |
1599 | my $re2 = qr/^$re1\z/; | |
f37ea7f0 | 1600 | is_tainted($re2); |
e08e52cf AMS |
1601 | |
1602 | my $re3 = "$re2"; | |
f37ea7f0 | 1603 | is_tainted($re3); |
e08e52cf | 1604 | } |
52a55424 | 1605 | |
09f04786 MS |
1606 | SKIP: { |
1607 | skip "system {} has different semantics on Win32", 1 if $Is_MSWin32; | |
1608 | ||
52a55424 RG |
1609 | # bug 20010221.005 |
1610 | local $ENV{PATH} .= $TAINT; | |
1611 | eval { system { "echo" } "/arg0", "arg1" }; | |
c3197de1 | 1612 | like($@, qr/^Insecure \$ENV/); |
52a55424 | 1613 | } |
09f04786 MS |
1614 | |
1615 | TODO: { | |
1616 | todo_skip 'tainted %ENV warning occludes tainted arguments warning', 22 | |
1617 | if $Is_VMS; | |
1618 | ||
1619 | # bug 20020208.005 plus some single arg exec/system extras | |
06bd1802 | 1620 | my $err = qr/^Insecure dependency/ ; |
c3197de1 NC |
1621 | is(eval { exec $TAINT, $TAINT }, undef, 'exec'); |
1622 | like($@, $err); | |
1623 | is(eval { exec $TAINT $TAINT }, undef, 'exec'); | |
1624 | like($@, $err); | |
1625 | is(eval { exec $TAINT $TAINT, $TAINT }, undef, 'exec'); | |
1626 | like($@, $err); | |
1627 | is(eval { exec $TAINT 'notaint' }, undef, 'exec'); | |
1628 | like($@, $err); | |
1629 | is(eval { exec {'notaint'} $TAINT }, undef, 'exec'); | |
1630 | like($@, $err); | |
1631 | ||
1632 | is(eval { system $TAINT, $TAINT }, undef, 'system'); | |
1633 | like($@, $err); | |
1634 | is(eval { system $TAINT $TAINT }, undef, 'system'); | |
1635 | like($@, $err); | |
1636 | is(eval { system $TAINT $TAINT, $TAINT }, undef, 'system'); | |
1637 | like($@, $err); | |
1638 | is(eval { system $TAINT 'notaint' }, undef, 'system'); | |
1639 | like($@, $err); | |
1640 | is(eval { system {'notaint'} $TAINT }, undef, 'system'); | |
1641 | like($@, $err); | |
09f04786 MS |
1642 | |
1643 | eval { | |
1644 | no warnings; | |
1645 | system("lskdfj does not exist","with","args"); | |
1646 | }; | |
c3197de1 | 1647 | is($@, ""); |
09f04786 | 1648 | |
7b903762 RGS |
1649 | eval { |
1650 | no warnings; | |
1651 | exec("lskdfj does not exist","with","args"); | |
1652 | }; | |
c3197de1 | 1653 | is($@, ""); |
6c8794e1 JH |
1654 | |
1655 | # If you add tests here update also the above skip block for VMS. | |
bbd7eb8a | 1656 | } |
a8c7c11a HS |
1657 | |
1658 | { | |
1659 | # [ID 20020704.001] taint propagation failure | |
1660 | use re 'taint'; | |
1661 | $TAINT =~ /(.*)/; | |
f37ea7f0 | 1662 | is_tainted(my $foo = $1); |
a8c7c11a | 1663 | } |
7b756e0a RGS |
1664 | |
1665 | { | |
c038024b RGS |
1666 | # [perl #24291] this used to dump core |
1667 | our %nonmagicalenv = ( PATH => "util" ); | |
7b756e0a RGS |
1668 | local *ENV = \%nonmagicalenv; |
1669 | eval { system("lskdfj"); }; | |
c3197de1 | 1670 | like($@, qr/^%ENV is aliased to another variable while running with -T switch/); |
c038024b | 1671 | local *ENV = *nonmagicalenv; |
7b756e0a | 1672 | eval { system("lskdfj"); }; |
c3197de1 | 1673 | like($@, qr/^%ENV is aliased to %nonmagicalenv while running with -T switch/); |
7b756e0a | 1674 | } |
0b4182de RD |
1675 | { |
1676 | # [perl #24248] | |
1677 | $TAINT =~ /(.*)/; | |
f37ea7f0 | 1678 | isnt_tainted($1); |
0b4182de | 1679 | my $notaint = $1; |
f37ea7f0 | 1680 | isnt_tainted($notaint); |
0b4182de RD |
1681 | |
1682 | my $l; | |
1683 | $notaint =~ /($notaint)/; | |
1684 | $l = $1; | |
f37ea7f0 NC |
1685 | isnt_tainted($1); |
1686 | isnt_tainted($l); | |
0b4182de RD |
1687 | $notaint =~ /($TAINT)/; |
1688 | $l = $1; | |
f37ea7f0 NC |
1689 | is_tainted($1); |
1690 | is_tainted($l); | |
0b4182de RD |
1691 | |
1692 | $TAINT =~ /($notaint)/; | |
1693 | $l = $1; | |
f37ea7f0 NC |
1694 | isnt_tainted($1); |
1695 | isnt_tainted($l); | |
0b4182de RD |
1696 | $TAINT =~ /($TAINT)/; |
1697 | $l = $1; | |
f37ea7f0 NC |
1698 | is_tainted($1); |
1699 | is_tainted($l); | |
0b4182de RD |
1700 | |
1701 | my $r; | |
1702 | ($r = $TAINT) =~ /($notaint)/; | |
f37ea7f0 | 1703 | isnt_tainted($1); |
0b4182de | 1704 | ($r = $TAINT) =~ /($TAINT)/; |
f37ea7f0 | 1705 | is_tainted($1); |
3511154c DM |
1706 | |
1707 | # [perl #24674] | |
1708 | # accessing $^O shoudn't taint it as a side-effect; | |
1709 | # assigning tainted data to it is now an error | |
1710 | ||
f37ea7f0 | 1711 | isnt_tainted($^O); |
3511154c | 1712 | if (!$^X) { } elsif ($^O eq 'bar') { } |
f37ea7f0 | 1713 | isnt_tainted($^O); |
4b24804c | 1714 | local $^O; # We're going to clobber something test infrastructure depends on. |
3511154c | 1715 | eval '$^O = $^X'; |
c3197de1 | 1716 | like($@, qr/Insecure dependency in/); |
0b4182de | 1717 | } |
23634c10 AL |
1718 | |
1719 | EFFECTIVELY_CONSTANTS: { | |
1720 | my $tainted_number = 12 + $TAINT0; | |
f37ea7f0 | 1721 | is_tainted( $tainted_number ); |
23634c10 AL |
1722 | |
1723 | # Even though it's always 0, it's still tainted | |
1724 | my $tainted_product = $tainted_number * 0; | |
f37ea7f0 | 1725 | is_tainted( $tainted_product ); |
c3197de1 | 1726 | is($tainted_product, 0); |
23634c10 AL |
1727 | } |
1728 | ||
1729 | TERNARY_CONDITIONALS: { | |
1730 | my $tainted_true = $TAINT . "blah blah blah"; | |
1731 | my $tainted_false = $TAINT0; | |
f37ea7f0 NC |
1732 | is_tainted( $tainted_true ); |
1733 | is_tainted( $tainted_false ); | |
23634c10 AL |
1734 | |
1735 | my $result = $tainted_true ? "True" : "False"; | |
c3197de1 | 1736 | is($result, "True"); |
f37ea7f0 | 1737 | isnt_tainted( $result ); |
23634c10 AL |
1738 | |
1739 | $result = $tainted_false ? "True" : "False"; | |
c3197de1 | 1740 | is($result, "False"); |
f37ea7f0 | 1741 | isnt_tainted( $result ); |
23634c10 AL |
1742 | |
1743 | my $untainted_whatever = "The Fabulous Johnny Cash"; | |
1744 | my $tainted_whatever = "Soft Cell" . $TAINT; | |
1745 | ||
1746 | $result = $tainted_true ? $tainted_whatever : $untainted_whatever; | |
c3197de1 | 1747 | is($result, "Soft Cell"); |
f37ea7f0 | 1748 | is_tainted( $result ); |
23634c10 AL |
1749 | |
1750 | $result = $tainted_false ? $tainted_whatever : $untainted_whatever; | |
c3197de1 | 1751 | is($result, "The Fabulous Johnny Cash"); |
f37ea7f0 | 1752 | isnt_tainted( $result ); |
23634c10 | 1753 | } |
65814f21 MS |
1754 | |
1755 | { | |
1756 | # rt.perl.org 5900 $1 remains tainted if... | |
1757 | # 1) The regular expression contains a scalar variable AND | |
1758 | # 2) The regular expression appears in an elsif clause | |
1759 | ||
1760 | my $foo = "abcdefghi" . $TAINT; | |
1761 | ||
1762 | my $valid_chars = 'a-z'; | |
1763 | if ( $foo eq '' ) { | |
1764 | } | |
1765 | elsif ( $foo =~ /([$valid_chars]+)/o ) { | |
f37ea7f0 | 1766 | isnt_tainted($1); |
65814f21 MS |
1767 | } |
1768 | ||
1769 | if ( $foo eq '' ) { | |
1770 | } | |
1771 | elsif ( my @bar = $foo =~ /([$valid_chars]+)/o ) { | |
c3197de1 | 1772 | ok(not any_tainted @bar); |
65814f21 MS |
1773 | } |
1774 | } | |
0a9c116b DM |
1775 | |
1776 | # at scope exit, a restored localised value should have its old | |
1777 | # taint status, not the taint status of the current statement | |
1778 | ||
1779 | { | |
1780 | our $x99 = $^X; | |
f37ea7f0 | 1781 | is_tainted($x99); |
0a9c116b DM |
1782 | |
1783 | $x99 = ''; | |
f37ea7f0 | 1784 | isnt_tainted($x99); |
0a9c116b DM |
1785 | |
1786 | my $c = do { local $x99; $^X }; | |
f37ea7f0 | 1787 | isnt_tainted($x99); |
0a9c116b DM |
1788 | } |
1789 | { | |
1790 | our $x99 = $^X; | |
f37ea7f0 | 1791 | is_tainted($x99); |
0a9c116b DM |
1792 | |
1793 | my $c = do { local $x99; '' }; | |
f37ea7f0 | 1794 | is_tainted($x99); |
0a9c116b DM |
1795 | } |
1796 | ||
27cc343c DM |
1797 | # an mg_get of a tainted value during localization shouldn't taint the |
1798 | # statement | |
1799 | ||
1800 | { | |
1801 | eval { local $0, eval '1' }; | |
c3197de1 | 1802 | is($@, ''); |
27cc343c | 1803 | } |
e26a4975 DM |
1804 | |
1805 | # [perl #8262] //g loops infinitely on tainted data | |
1806 | ||
1807 | { | |
1808 | my @a; | |
fd69380d DM |
1809 | $a[0] = $^X . '-'; |
1810 | $a[0]=~ m/(.)/g; | |
1811 | cmp_ok pos($a[0]), '>', 0, "infinite m//g on arrays (aelemfast)"; | |
1812 | ||
1813 | my $i = 1; | |
1814 | $a[$i] = $^X . '-'; | |
1815 | $a[$i]=~ m/(.)/g; | |
1816 | cmp_ok pos($a[$i]), '>', 0, "infinite m//g on arrays (aelem)"; | |
1817 | ||
1818 | my %h; | |
1819 | $h{a} = $^X . '-'; | |
1820 | $h{a}=~ m/(.)/g; | |
1821 | cmp_ok pos($h{a}), '>', 0, "infinite m//g on hashes (helem)"; | |
e26a4975 | 1822 | } |
0aa395f8 NC |
1823 | |
1824 | SKIP: | |
1825 | { | |
1826 | my $got_dualvar; | |
1827 | eval 'use Scalar::Util "dualvar"; $got_dualvar++'; | |
1828 | skip "No Scalar::Util::dualvar" unless $got_dualvar; | |
1829 | my $a = Scalar::Util::dualvar(3, $^X); | |
1830 | my $b = $a + 5; | |
1831 | is ($b, 8, "Arithmetic on tainted dualvars works"); | |
1832 | } | |
f27977c3 MH |
1833 | |
1834 | # opening '|-' should not trigger $ENV{PATH} check | |
1835 | ||
1836 | { | |
1837 | SKIP: { | |
1838 | skip "fork() is not available", 3 unless $Config{'d_fork'}; | |
1fb83d06 SS |
1839 | skip "opening |- is not stable on threaded Open/MirBSD with taint", 3 |
1840 | if $Config{useithreads} and $Is_OpenBSD || $Is_MirBSD; | |
f27977c3 MH |
1841 | |
1842 | $ENV{'PATH'} = $TAINT; | |
1843 | local $SIG{'PIPE'} = 'IGNORE'; | |
1844 | eval { | |
1845 | my $pid = open my $pipe, '|-'; | |
1846 | if (!defined $pid) { | |
1847 | die "open failed: $!"; | |
1848 | } | |
1849 | if (!$pid) { | |
1850 | kill 'KILL', $$; # child suicide | |
1851 | } | |
1852 | close $pipe; | |
1853 | }; | |
c3197de1 NC |
1854 | unlike($@, qr/Insecure \$ENV/, 'fork triggers %ENV check'); |
1855 | is($@, '', 'pipe/fork/open/close failed'); | |
f27977c3 MH |
1856 | eval { |
1857 | open my $pipe, "|$Invoke_Perl -e 1"; | |
1858 | close $pipe; | |
1859 | }; | |
c3197de1 | 1860 | like($@, qr/Insecure \$ENV/, 'popen neglects %ENV check'); |
f27977c3 MH |
1861 | } |
1862 | } | |
5d121f7f RD |
1863 | |
1864 | { | |
1865 | package AUTOLOAD_TAINT; | |
1866 | sub AUTOLOAD { | |
1867 | our $AUTOLOAD; | |
1868 | return if $AUTOLOAD =~ /DESTROY/; | |
1869 | if ($AUTOLOAD =~ /untainted/) { | |
f37ea7f0 | 1870 | main::isnt_tainted($AUTOLOAD, '$AUTOLOAD can be untainted'); |
d40bf27b | 1871 | my $copy = $AUTOLOAD; |
f37ea7f0 | 1872 | main::isnt_tainted($copy, '$AUTOLOAD can be untainted'); |
5d121f7f | 1873 | } else { |
f37ea7f0 | 1874 | main::is_tainted($AUTOLOAD, '$AUTOLOAD can be tainted'); |
d40bf27b | 1875 | my $copy = $AUTOLOAD; |
f37ea7f0 | 1876 | main::is_tainted($copy, '$AUTOLOAD can be tainted'); |
5d121f7f RD |
1877 | } |
1878 | } | |
1879 | ||
1880 | package main; | |
1881 | my $o = bless [], 'AUTOLOAD_TAINT'; | |
d40bf27b | 1882 | $o->untainted; |
5d121f7f RD |
1883 | $o->$TAINT; |
1884 | $o->untainted; | |
1885 | } | |
1886 | ||
20ee07fb RGS |
1887 | { |
1888 | # tests for tainted format in s?printf | |
1889 | eval { printf($TAINT . "# %s\n", "foo") }; | |
1890 | like($@, qr/^Insecure dependency in printf/, q/printf doesn't like tainted formats/); | |
1891 | eval { printf("# %s\n", $TAINT . "foo") }; | |
1892 | ok(!$@, q/printf accepts other tainted args/); | |
1893 | eval { sprintf($TAINT . "# %s\n", "foo") }; | |
1894 | like($@, qr/^Insecure dependency in sprintf/, q/sprintf doesn't like tainted formats/); | |
1895 | eval { sprintf("# %s\n", $TAINT . "foo") }; | |
1896 | ok(!$@, q/sprintf accepts other tainted args/); | |
1897 | } | |
085bde85 NC |
1898 | |
1899 | { | |
1900 | # 40708 | |
1901 | my $n = 7e9; | |
1902 | 8e9 - $n; | |
1903 | ||
1904 | my $val = $n; | |
1905 | is ($val, '7000000000', 'Assignment to untainted variable'); | |
1906 | $val = $TAINT; | |
1907 | $val = $n; | |
1908 | is ($val, '7000000000', 'Assignment to tainted variable'); | |
1909 | } | |
5e500fc8 NC |
1910 | |
1911 | { | |
5e500fc8 NC |
1912 | my $val = 0; |
1913 | my $tainted = '1' . $TAINT; | |
1914 | eval '$val = eval $tainted;'; | |
1915 | is ($val, 0, "eval doesn't like tainted strings"); | |
1916 | like ($@, qr/^Insecure dependency in eval/); | |
1917 | ||
abb7fb96 NC |
1918 | # Rather nice code to get a tainted undef by from Rick Delaney |
1919 | open FH, "test.pl" or die $!; | |
af2d3def RD |
1920 | seek FH, 0, 2 or die $!; |
1921 | $tainted = <FH>; | |
5e500fc8 NC |
1922 | |
1923 | eval 'eval $tainted'; | |
1924 | like ($@, qr/^Insecure dependency in eval/); | |
1925 | } | |
beeaa6fd | 1926 | |
d3706118 NC |
1927 | foreach my $ord (78, 163, 256) { |
1928 | # 47195 | |
1929 | my $line = 'A1' . $TAINT . chr $ord; | |
1930 | chop $line; | |
1931 | is($line, 'A1'); | |
1932 | $line =~ /(A\S*)/; | |
f37ea7f0 | 1933 | isnt_tainted($1, "\\S match with chr $ord"); |
d3706118 NC |
1934 | } |
1935 | ||
ec93b65f CS |
1936 | { |
1937 | # 59998 | |
1938 | sub cr { my $x = crypt($_[0], $_[1]); $x } | |
1939 | sub co { my $x = ~$_[0]; $x } | |
1940 | my ($a, $b); | |
1941 | $a = cr('hello', 'foo' . $TAINT); | |
1942 | $b = cr('hello', 'foo'); | |
f37ea7f0 NC |
1943 | is_tainted($a, "tainted crypt"); |
1944 | isnt_tainted($b, "untainted crypt"); | |
ec93b65f CS |
1945 | $a = co('foo' . $TAINT); |
1946 | $b = co('foo'); | |
f37ea7f0 NC |
1947 | is_tainted($a, "tainted complement"); |
1948 | isnt_tainted($b, "untainted complement"); | |
ec93b65f CS |
1949 | } |
1950 | ||
302c0c93 NC |
1951 | { |
1952 | my @data = qw(bonk zam zlonk qunckkk); | |
1953 | # Clearly some sort of usenet bang-path | |
1954 | my $string = $TAINT . join "!", @data; | |
1955 | ||
f37ea7f0 | 1956 | is_tainted($string, "tainted data"); |
302c0c93 NC |
1957 | |
1958 | my @got = split /!|,/, $string; | |
1959 | ||
1960 | # each @got would be useful here, but I want the test for earlier perls | |
1961 | for my $i (0 .. $#data) { | |
f37ea7f0 | 1962 | is_tainted($got[$i], "tainted result $i"); |
302c0c93 NC |
1963 | is($got[$i], $data[$i], "correct content $i"); |
1964 | } | |
1965 | ||
f37ea7f0 | 1966 | is_tainted($string, "still tainted data"); |
302c0c93 NC |
1967 | |
1968 | my @got = split /[!,]/, $string; | |
1969 | ||
1970 | # each @got would be useful here, but I want the test for earlier perls | |
1971 | for my $i (0 .. $#data) { | |
f37ea7f0 | 1972 | is_tainted($got[$i], "tainted result $i"); |
302c0c93 NC |
1973 | is($got[$i], $data[$i], "correct content $i"); |
1974 | } | |
1975 | ||
f37ea7f0 | 1976 | is_tainted($string, "still tainted data"); |
302c0c93 NC |
1977 | |
1978 | my @got = split /!/, $string; | |
1979 | ||
1980 | # each @got would be useful here, but I want the test for earlier perls | |
1981 | for my $i (0 .. $#data) { | |
f37ea7f0 | 1982 | is_tainted($got[$i], "tainted result $i"); |
302c0c93 NC |
1983 | is($got[$i], $data[$i], "correct content $i"); |
1984 | } | |
1985 | } | |
1986 | ||
3c4fb04a RB |
1987 | # Bug RT #52552 - broken by change at git commit id f337b08 |
1988 | { | |
1989 | my $x = $TAINT. q{print "Hello world\n"}; | |
1990 | my $y = pack "a*", $x; | |
f37ea7f0 | 1991 | is_tainted($y, "pack a* preserves tainting"); |
3c4fb04a RB |
1992 | |
1993 | my $z = pack "A*", q{print "Hello world\n"}.$TAINT; | |
f37ea7f0 | 1994 | is_tainted($z, "pack A* preserves tainting"); |
3c4fb04a RB |
1995 | |
1996 | my $zz = pack "a*a*", q{print "Hello world\n"}, $TAINT; | |
f37ea7f0 | 1997 | is_tainted($zz, "pack a*a* preserves tainting"); |
3c4fb04a RB |
1998 | } |
1999 | ||
0097b436 DM |
2000 | # Bug RT #61976 tainted $! would show numeric rather than string value |
2001 | ||
2002 | { | |
2003 | my $tainted_path = substr($^X,0,0) . "/no/such/file"; | |
2004 | my $err; | |
2005 | # $! is used in a tainted expression, so gets tainted | |
2006 | open my $fh, $tainted_path or $err= "$!"; | |
2007 | unlike($err, qr/^\d+$/, 'tainted $!'); | |
2008 | } | |
2009 | ||
b112cff9 DM |
2010 | { |
2011 | # #6758: tainted values become untainted in tied hashes | |
2012 | # (also applies to other value magic such as pos) | |
2013 | ||
2014 | ||
2015 | package P6758; | |
2016 | ||
2017 | sub TIEHASH { bless {} } | |
2018 | sub TIEARRAY { bless {} } | |
2019 | ||
2020 | my $i = 0; | |
2021 | ||
2022 | sub STORE { | |
f37ea7f0 NC |
2023 | main::is_tainted($_[1], "tied arg1 tainted"); |
2024 | main::is_tainted($_[2], "tied arg2 tainted"); | |
b112cff9 DM |
2025 | $i++; |
2026 | } | |
2027 | ||
2028 | package main; | |
2029 | ||
2030 | my ($k,$v) = qw(1111 val); | |
2031 | taint_these($k,$v); | |
2032 | tie my @array, 'P6758'; | |
2033 | tie my %hash , 'P6758'; | |
2034 | $array[$k] = $v; | |
2035 | $hash{$k} = $v; | |
2036 | ok $i == 2, "tied STORE called correct number of times"; | |
2037 | } | |
2038 | ||
3e6bd4bf DM |
2039 | # Bug RT #45167 the return value of sprintf sometimes wasn't tainted |
2040 | # when the args were tainted. This only occured on the first use of | |
2041 | # sprintf; after that, its TARG has taint magic attached, so setmagic | |
2042 | # at the end works. That's why there are multiple sprintf's below, rather | |
93f09d7b | 2043 | # than just one wrapped in an inner loop. Also, any plaintext between |
3e6bd4bf DM |
2044 | # fprmat entires would correctly cause tainting to get set. so test with |
2045 | # "%s%s" rather than eg "%s %s". | |
2046 | ||
2047 | { | |
2048 | for my $var1 ($TAINT, "123") { | |
2049 | for my $var2 ($TAINT0, "456") { | |
8e29defb NC |
2050 | is( tainted(sprintf '%s', $var1, $var2), tainted($var1), |
2051 | "sprintf '%s', '$var1', '$var2'" ); | |
2052 | is( tainted(sprintf ' %s', $var1, $var2), tainted($var1), | |
2053 | "sprintf ' %s', '$var1', '$var2'" ); | |
2054 | is( tainted(sprintf '%s%s', $var1, $var2), | |
2055 | tainted($var1) || tainted($var2), | |
2056 | "sprintf '%s%s', '$var1', '$var2'" ); | |
3e6bd4bf DM |
2057 | } |
2058 | } | |
2059 | } | |
2060 | ||
2061 | ||
447ee134 DM |
2062 | # Bug RT #67962: old tainted $1 gets treated as tainted |
2063 | # in next untainted # match | |
2064 | ||
2065 | { | |
2066 | use re 'taint'; | |
2067 | "abc".$TAINT =~ /(.*)/; # make $1 tainted | |
f37ea7f0 | 2068 | is_tainted($1, '$1 should be tainted'); |
447ee134 DM |
2069 | |
2070 | my $untainted = "abcdef"; | |
f37ea7f0 | 2071 | isnt_tainted($untainted, '$untainted should be untainted'); |
447ee134 | 2072 | $untainted =~ s/(abc)/$1/; |
f37ea7f0 | 2073 | isnt_tainted($untainted, '$untainted should still be untainted'); |
447ee134 | 2074 | $untainted =~ s/(abc)/x$1/; |
f37ea7f0 | 2075 | isnt_tainted($untainted, '$untainted should yet still be untainted'); |
447ee134 DM |
2076 | } |
2077 | ||
7e6078c6 | 2078 | { |
d4456f89 JD |
2079 | # On Windows we can't spawn a fresh Perl interpreter unless at |
2080 | # least the Windows system directory (usually C:\Windows\System32) | |
2081 | # is still on the PATH. There is however no way to determine the | |
2082 | # actual path on the current system without loading the Win32 | |
2083 | # module, so we just restore the original $ENV{PATH} here. | |
2084 | local $ENV{PATH} = $ENV{PATH}; | |
2085 | $ENV{PATH} = $old_env_path if $Is_MSWin32; | |
2086 | ||
7e6078c6 NT |
2087 | fresh_perl_is(<<'end', "ok", { switches => [ '-T' ] }, |
2088 | $TAINT = substr($^X, 0, 0); | |
00cb33d6 FC |
2089 | formline('@'.('<'x("2000".$TAINT)).' | @*', 'hallo', 'welt'); |
2090 | print "ok"; | |
7e6078c6 NT |
2091 | end |
2092 | "formline survives a tainted dynamic picture"); | |
2093 | } | |
0097b436 | 2094 | |
125b9982 | 2095 | { |
f37ea7f0 | 2096 | isnt_tainted($^A, "format accumulator not tainted yet"); |
99e6ea26 | 2097 | formline('@ | @*', 'hallo' . $TAINT, 'welt'); |
f37ea7f0 | 2098 | is_tainted($^A, "tainted formline argument makes a tainted accumulator"); |
99e6ea26 | 2099 | $^A = ""; |
f37ea7f0 | 2100 | isnt_tainted($^A, "accumulator can be explicitly untainted"); |
99e6ea26 | 2101 | formline('@' .('<'*5) . ' | @*', 'hallo', 'welt'); |
f37ea7f0 | 2102 | isnt_tainted($^A, "accumulator still untainted"); |
99e6ea26 | 2103 | $^A = "" . $TAINT; |
f37ea7f0 | 2104 | is_tainted($^A, "accumulator can be explicitly tainted"); |
99e6ea26 | 2105 | formline('@' .('<'*5) . ' | @*', 'hallo', 'welt'); |
f37ea7f0 | 2106 | is_tainted($^A, "accumulator still tainted"); |
99e6ea26 | 2107 | $^A = ""; |
f37ea7f0 | 2108 | isnt_tainted($^A, "accumulator untainted again"); |
99e6ea26 | 2109 | formline('@' .('<'*5) . ' | @*', 'hallo', 'welt'); |
f37ea7f0 | 2110 | isnt_tainted($^A, "accumulator still untainted"); |
99e6ea26 | 2111 | formline('@' .('<'*(5+$TAINT0)) . ' | @*', 'hallo', 'welt'); |
125b9982 NT |
2112 | TODO: { |
2113 | local $::TODO = "get magic handled too late?"; | |
f37ea7f0 | 2114 | is_tainted($^A, "the accumulator should be tainted already"); |
125b9982 | 2115 | } |
f37ea7f0 | 2116 | is_tainted($^A, "tainted formline picture makes a tainted accumulator"); |
99e6ea26 NT |
2117 | } |
2118 | ||
929fffa4 KW |
2119 | { # Bug #80610 |
2120 | "Constant(1)" =~ / ^ ([a-z_]\w*) (?: [(] (.*) [)] )? $ /xi; | |
2121 | my $a = $1; | |
2122 | my $b = $2; | |
f37ea7f0 NC |
2123 | isnt_tainted($a, "regex optimization of single char /[]/i doesn't taint"); |
2124 | isnt_tainted($b, "regex optimization of single char /[]/i doesn't taint"); | |
929fffa4 KW |
2125 | } |
2126 | ||
8985fe98 DM |
2127 | { |
2128 | # RT 81230: tainted value during FETCH created extra ref to tied obj | |
2129 | ||
2130 | package P81230; | |
2131 | use warnings; | |
2132 | ||
2133 | my %h; | |
2134 | ||
2135 | sub TIEHASH { | |
2136 | my $x = $^X; # tainted | |
2137 | bless \$x; | |
2138 | } | |
2139 | sub FETCH { my $x = $_[0]; $$x . "" } | |
2140 | ||
2141 | tie %h, 'P81230'; | |
2142 | ||
2143 | my $w = ""; | |
2144 | local $SIG{__WARN__} = sub { $w .= "@_" }; | |
2145 | ||
2146 | untie %h if $h{"k"}; | |
2147 | ||
2148 | ::is($w, "", "RT 81230"); | |
2149 | } | |
2150 | ||
5a909b52 GG |
2151 | { |
2152 | # Compiling a subroutine inside a tainted expression does not make the | |
2153 | # constant folded values tainted. | |
2154 | my $x = sub { "x" . "y" }; | |
2155 | my $y = $ENV{PATH} . $x->(); # Compile $x inside a tainted expression | |
2156 | my $z = $x->(); | |
f37ea7f0 | 2157 | isnt_tainted($z, "Constants folded value not tainted"); |
5a909b52 | 2158 | } |
8985fe98 | 2159 | |
9274aefd DM |
2160 | { |
2161 | # now that regexes are first class SVs, make sure that they themselves | |
2162 | # as well as references to them are tainted | |
2163 | ||
2164 | my $rr = qr/(.)$TAINT/; | |
2165 | my $r = $$rr; # bare REGEX | |
2166 | my $s ="abc"; | |
2167 | ok($s =~ s/$r/x/, "match bare regex"); | |
f37ea7f0 | 2168 | is_tainted($s, "match bare regex taint"); |
9274aefd DM |
2169 | is($s, 'xbc', "match bare regex taint value"); |
2170 | } | |
2171 | ||
0e9be77f DM |
2172 | { |
2173 | # [perl #82616] security Issues with user-defined \p{} properties | |
2174 | # A using a tainted user-defined property should croak | |
2175 | ||
2176 | sub IsA { sprintf "%02x", ord("A") } | |
2177 | ||
2178 | my $prop = "IsA"; | |
2179 | ok("A" =~ /\p{$prop}/, "user-defined property: non-tainted case"); | |
2180 | $prop = "IsA$TAINT"; | |
2181 | eval { "A" =~ /\p{$prop}/}; | |
2182 | like($@, qr/Insecure user-defined property \\p{main::IsA}/, | |
2183 | "user-defined property: tainted case"); | |
2184 | } | |
2185 | ||
beeaa6fd NC |
2186 | # This may bomb out with the alarm signal so keep it last |
2187 | SKIP: { | |
2188 | skip "No alarm()" unless $Config{d_alarm}; | |
2189 | # Test from RT #41831] | |
2190 | # [PATCH] Bug & fix: hang when using study + taint mode (perl 5.6.1, 5.8.x) | |
2191 | ||
2192 | my $DATA = <<'END' . $TAINT; | |
2193 | line1 is here | |
2194 | line2 is here | |
2195 | line3 is here | |
2196 | line4 is here | |
2197 | ||
2198 | END | |
2199 | ||
2200 | #study $DATA; | |
2201 | ||
2202 | ## don't set $SIG{ALRM}, since we'd never get to a user-level handler as | |
2203 | ## perl is stuck in a regexp infinite loop! | |
2204 | ||
2205 | alarm(10); | |
2206 | ||
2207 | if ($DATA =~ /^line2.*line4/m) { | |
2208 | fail("Should not be a match") | |
2209 | } else { | |
2210 | pass("Match on tainted multiline data should fail promptly"); | |
2211 | } | |
2212 | ||
2213 | alarm(0); | |
2214 | } | |
2215 | __END__ | |
2216 | # Keep the previous test last |