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'; | |
632e037a | 12 | require './test.pl'; |
43ece5b1 | 13 | set_up_inc('../lib'); |
fac2c98c | 14 | require './loc_tools.pl'; |
1e422769 | 15 | } |
16 | ||
17 | use strict; | |
18 | use Config; | |
19 | ||
7896dde7 | 20 | plan tests => 1041; |
7c36658b | 21 | |
0ecd3ba2 MG |
22 | $| = 1; |
23 | ||
83461ff8 | 24 | my $ipcsysv; # did we manage to load IPC::SysV? |
c9f931b8 | 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); | |
c4f4b223 Z |
86 | # A tainted non-empty string |
87 | my $TAINTXYZ = "xyz".$TAINT; | |
1e422769 | 88 | # A tainted zero, useful for tainting numbers |
09f04786 MS |
89 | my $TAINT0; |
90 | { | |
91 | no warnings; | |
92 | $TAINT0 = 0 + $TAINT; | |
93 | } | |
1e422769 | 94 | |
95 | # This taints each argument passed. All must be lvalues. | |
96 | # Side effect: It also stringifies them. :-( | |
97 | sub taint_these (@) { | |
98 | for (@_) { $_ .= $TAINT } | |
99 | } | |
100 | ||
101 | # How to identify taint when you see it | |
1e422769 | 102 | sub tainted ($) { |
6e7325e5 | 103 | local $@; # Don't pollute caller's value. |
81cba34d | 104 | not eval { join("",@_), kill 0; 1 }; |
1e422769 | 105 | } |
1e422769 | 106 | |
f37ea7f0 NC |
107 | sub is_tainted { |
108 | my $thing = shift; | |
109 | local $::Level = $::Level + 1; | |
81cba34d | 110 | ok(tainted($thing), @_); |
f37ea7f0 NC |
111 | } |
112 | ||
113 | sub isnt_tainted { | |
114 | my $thing = shift; | |
115 | local $::Level = $::Level + 1; | |
81cba34d | 116 | ok(!tainted($thing), @_); |
f37ea7f0 NC |
117 | } |
118 | ||
8184526b | 119 | sub violates_taint { |
ef5cbc63 NC |
120 | my ($code, $what, $desc) = @_; |
121 | $desc //= $what; | |
8184526b NC |
122 | local $::Level = $::Level + 1; |
123 | is(eval { $code->(); }, undef, $desc); | |
ef5cbc63 | 124 | like($@, qr/^Insecure dependency in $what while running with -T switch/); |
8184526b NC |
125 | } |
126 | ||
1e422769 | 127 | # We need an external program to call. |
c0a22fcc | 128 | my $ECHO = ($Is_MSWin32 ? ".\\tmpecho$$" : ($Is_NetWare ? "tmpecho$$" : "./tmpecho$$")); |
1e422769 | 129 | END { unlink $ECHO } |
22d7dfed NC |
130 | open my $fh, '>', $ECHO or die "Can't create $ECHO: $!"; |
131 | print $fh 'print "@ARGV\n"', "\n"; | |
132 | close $fh; | |
1e422769 | 133 | my $echo = "$Invoke_Perl $ECHO"; |
134 | ||
22d7dfed | 135 | my $TEST = 'TEST'; |
dc459aad | 136 | |
1e422769 | 137 | # First, let's make sure that Perl is checking the dangerous |
138 | # environment variables. Maybe they aren't set yet, so we'll | |
139 | # taint them ourselves. | |
140 | { | |
141 | $ENV{'DCL$PATH'} = '' if $Is_VMS; | |
142 | ||
e59c8b07 | 143 | $ENV{PATH} = ($Is_Cygwin) ? '/usr/bin' : ''; |
c90c0ff4 | 144 | delete @ENV{@MoreEnv}; |
7bac28a0 | 145 | $ENV{TERM} = 'dumb'; |
146 | ||
c3197de1 | 147 | is(eval { `$echo 1` }, "1\n"); |
09f04786 MS |
148 | |
149 | SKIP: { | |
150 | skip "Environment tainting tests skipped", 4 | |
7b903762 | 151 | if $Is_MSWin32 || $Is_NetWare || $Is_VMS || $Is_Dos; |
7bac28a0 | 152 | |
7bac28a0 | 153 | my @vars = ('PATH', @MoreEnv); |
154 | while (my $v = $vars[0]) { | |
155 | local $ENV{$v} = $TAINT; | |
156 | last if eval { `$echo 1` }; | |
92e8e650 | 157 | last unless $@ =~ /^Insecure \$ENV\{$v\}/; |
7bac28a0 | 158 | shift @vars; |
159 | } | |
c3197de1 | 160 | is("@vars", ""); |
c90c0ff4 | 161 | |
162 | # tainted $TERM is unsafe only if it contains metachars | |
163 | local $ENV{TERM}; | |
164 | $ENV{TERM} = 'e=mc2'; | |
c3197de1 | 165 | is(eval { `$echo 1` }, "1\n"); |
c90c0ff4 | 166 | $ENV{TERM} = 'e=mc2' . $TAINT; |
c3197de1 | 167 | is(eval { `$echo 1` }, undef); |
92e8e650 | 168 | like($@, qr/^Insecure \$ENV\{TERM\}/); |
5aabfad6 | 169 | } |
7bac28a0 | 170 | |
9607fc9c | 171 | my $tmp; |
2986a63f | 172 | if ($^O eq 'os2' || $^O eq 'amigaos' || $Is_MSWin32 || $Is_NetWare || $Is_Dos) { |
48c036b1 GS |
173 | print "# all directories are writeable\n"; |
174 | } | |
175 | else { | |
9607fc9c | 176 | $tmp = (grep { defined and -d and (stat _)[2] & 2 } |
099f76bb | 177 | qw(sys$scratch /tmp /var/tmp /usr/tmp), |
9607fc9c | 178 | @ENV{qw(TMP TEMP)})[0] |
179 | or print "# can't find world-writeable directory to test PATH\n"; | |
180 | } | |
181 | ||
09f04786 MS |
182 | SKIP: { |
183 | skip "all directories are writeable", 2 unless $tmp; | |
184 | ||
7bac28a0 | 185 | local $ENV{PATH} = $tmp; |
c3197de1 | 186 | is(eval { `$echo 1` }, undef); |
22636a29 BF |
187 | # Message can be different depending on whether echo |
188 | # is a builtin or not | |
92e8e650 | 189 | like($@, qr/^Insecure (?:directory in )?\$ENV\{PATH\}/); |
1e422769 | 190 | } |
191 | ||
ba0a4150 FC |
192 | # Relative paths in $ENV{PATH} are always implicitly tainted. |
193 | SKIP: { | |
194 | skip "Do these work on VMS?", 4 if $Is_VMS; | |
195 | skip "Not applicable to DOSish systems", 4 if! $tmp; | |
196 | ||
197 | local $ENV{PATH} = '.'; | |
198 | is(eval { `$echo 1` }, undef); | |
92e8e650 | 199 | like($@, qr/^Insecure (?:directory in )?\$ENV\{PATH\}/); |
ba0a4150 FC |
200 | |
201 | # Backslash should not fool perl into thinking that this is one | |
202 | # path. | |
203 | local $ENV{PATH} = '/\:.'; | |
204 | is(eval { `$echo 1` }, undef); | |
92e8e650 | 205 | like($@, qr/^Insecure (?:directory in )?\$ENV\{PATH\}/); |
ba0a4150 FC |
206 | } |
207 | ||
09f04786 MS |
208 | SKIP: { |
209 | skip "This is not VMS", 4 unless $Is_VMS; | |
210 | ||
1e422769 | 211 | $ENV{'DCL$PATH'} = $TAINT; |
81e6f6d0 | 212 | is(eval { `$echo 1` }, undef); |
92e8e650 | 213 | like($@, qr/^Insecure \$ENV\{DCL\$PATH\}/); |
09f04786 MS |
214 | SKIP: { |
215 | skip q[can't find world-writeable directory to test DCL$PATH], 2 | |
25fb98c0 | 216 | unless $tmp; |
09f04786 | 217 | |
9607fc9c | 218 | $ENV{'DCL$PATH'} = $tmp; |
81e6f6d0 | 219 | is(eval { `$echo 1` }, undef); |
92e8e650 | 220 | like($@, qr/^Insecure directory in \$ENV\{DCL\$PATH\}/); |
9607fc9c | 221 | } |
1e422769 | 222 | $ENV{'DCL$PATH'} = ''; |
223 | } | |
1e422769 | 224 | } |
225 | ||
226 | # Let's see that we can taint and untaint as needed. | |
227 | { | |
228 | my $foo = $TAINT; | |
f37ea7f0 | 229 | is_tainted($foo); |
9607fc9c | 230 | |
231 | # That was a sanity check. If it failed, stop the insanity! | |
232 | die "Taint checks don't seem to be enabled" unless tainted $foo; | |
1e422769 | 233 | |
234 | $foo = "foo"; | |
f37ea7f0 | 235 | isnt_tainted($foo); |
1e422769 | 236 | |
237 | taint_these($foo); | |
f37ea7f0 | 238 | is_tainted($foo); |
1e422769 | 239 | |
240 | my @list = 1..10; | |
81cba34d | 241 | isnt_tainted($_) foreach @list; |
1e422769 | 242 | taint_these @list[1,3,5,7,9]; |
e75436bf | 243 | is_tainted($_) foreach @list[1,3,5,7,9]; |
81cba34d | 244 | isnt_tainted($_) foreach @list[0,2,4,6,8]; |
1e422769 | 245 | |
246 | ($foo) = $foo =~ /(.+)/; | |
f37ea7f0 | 247 | isnt_tainted($foo); |
1e422769 | 248 | |
c769ddc7 DM |
249 | my ($desc, $s, $res, $res2, $one); |
250 | ||
251 | $desc = "match with string tainted"; | |
252 | ||
253 | $s = 'abcd' . $TAINT; | |
254 | $res = $s =~ /(.+)/; | |
255 | $one = $1; | |
f37ea7f0 NC |
256 | is_tainted($s, "$desc: s tainted"); |
257 | isnt_tainted($res, "$desc: res not tainted"); | |
258 | isnt_tainted($one, "$desc: \$1 not tainted"); | |
c769ddc7 DM |
259 | is($res, 1, "$desc: res value"); |
260 | is($one, 'abcd', "$desc: \$1 value"); | |
261 | ||
262 | $desc = "match /g with string tainted"; | |
263 | ||
264 | $s = 'abcd' . $TAINT; | |
265 | $res = $s =~ /(.)/g; | |
266 | $one = $1; | |
f37ea7f0 NC |
267 | is_tainted($s, "$desc: s tainted"); |
268 | isnt_tainted($res, "$desc: res not tainted"); | |
269 | isnt_tainted($one, "$desc: \$1 not tainted"); | |
c769ddc7 DM |
270 | is($res, 1, "$desc: res value"); |
271 | is($one, 'a', "$desc: \$1 value"); | |
272 | ||
273 | $desc = "match with string tainted, list cxt"; | |
274 | ||
275 | $s = 'abcd' . $TAINT; | |
276 | ($res) = $s =~ /(.+)/; | |
277 | $one = $1; | |
f37ea7f0 NC |
278 | is_tainted($s, "$desc: s tainted"); |
279 | isnt_tainted($res, "$desc: res not tainted"); | |
280 | isnt_tainted($one, "$desc: \$1 not tainted"); | |
c769ddc7 DM |
281 | is($res, 'abcd', "$desc: res value"); |
282 | is($one, 'abcd', "$desc: \$1 value"); | |
283 | ||
284 | $desc = "match /g with string tainted, list cxt"; | |
285 | ||
286 | $s = 'abcd' . $TAINT; | |
287 | ($res, $res2) = $s =~ /(.)/g; | |
288 | $one = $1; | |
f37ea7f0 NC |
289 | is_tainted($s, "$desc: s tainted"); |
290 | isnt_tainted($res, "$desc: res not tainted"); | |
291 | isnt_tainted($res2,"$desc: res2 not tainted"); | |
292 | isnt_tainted($one, "$desc: \$1 not tainted"); | |
c769ddc7 DM |
293 | is($res, 'a', "$desc: res value"); |
294 | is($res2,'b', "$desc: res2 value"); | |
295 | is($one, 'd', "$desc: \$1 value"); | |
296 | ||
297 | $desc = "match with pattern tainted"; | |
298 | ||
299 | $s = 'abcd'; | |
300 | $res = $s =~ /$TAINT(.+)/; | |
301 | $one = $1; | |
f37ea7f0 NC |
302 | isnt_tainted($s, "$desc: s not tainted"); |
303 | isnt_tainted($res, "$desc: res not tainted"); | |
304 | is_tainted($one, "$desc: \$1 tainted"); | |
c769ddc7 DM |
305 | is($res, 1, "$desc: res value"); |
306 | is($one, 'abcd', "$desc: \$1 value"); | |
307 | ||
308 | $desc = "match /g with pattern tainted"; | |
309 | ||
310 | $s = 'abcd'; | |
311 | $res = $s =~ /$TAINT(.)/g; | |
312 | $one = $1; | |
f37ea7f0 NC |
313 | isnt_tainted($s, "$desc: s not tainted"); |
314 | isnt_tainted($res, "$desc: res not tainted"); | |
315 | is_tainted($one, "$desc: \$1 tainted"); | |
c769ddc7 DM |
316 | is($res, 1, "$desc: res value"); |
317 | is($one, 'a', "$desc: \$1 value"); | |
318 | ||
569f7fc5 | 319 | SKIP: { |
ef9d5242 | 320 | skip 'Locales not available', 10 unless locales_enabled('LC_CTYPE'); |
c769ddc7 | 321 | |
569f7fc5 | 322 | $desc = "match with pattern tainted via locale"; |
c769ddc7 | 323 | |
569f7fc5 JR |
324 | $s = 'abcd'; |
325 | { | |
5f1269ab | 326 | use locale; |
569f7fc5 JR |
327 | $res = $s =~ /(\w+)/; $one = $1; |
328 | } | |
329 | isnt_tainted($s, "$desc: s not tainted"); | |
330 | isnt_tainted($res, "$desc: res not tainted"); | |
331 | is_tainted($one, "$desc: \$1 tainted"); | |
332 | is($res, 1, "$desc: res value"); | |
333 | is($one, 'abcd', "$desc: \$1 value"); | |
334 | ||
335 | $desc = "match /g with pattern tainted via locale"; | |
336 | ||
337 | $s = 'abcd'; | |
338 | { | |
5f1269ab | 339 | use locale; |
569f7fc5 JR |
340 | $res = $s =~ /(\w)/g; $one = $1; |
341 | } | |
342 | isnt_tainted($s, "$desc: s not tainted"); | |
343 | isnt_tainted($res, "$desc: res not tainted"); | |
344 | is_tainted($one, "$desc: \$1 tainted"); | |
345 | is($res, 1, "$desc: res value"); | |
346 | is($one, 'a', "$desc: \$1 value"); | |
347 | } | |
c769ddc7 DM |
348 | |
349 | $desc = "match with pattern tainted, list cxt"; | |
350 | ||
351 | $s = 'abcd'; | |
352 | ($res) = $s =~ /$TAINT(.+)/; | |
353 | $one = $1; | |
f37ea7f0 NC |
354 | isnt_tainted($s, "$desc: s not tainted"); |
355 | is_tainted($res, "$desc: res tainted"); | |
356 | is_tainted($one, "$desc: \$1 tainted"); | |
c769ddc7 DM |
357 | is($res, 'abcd', "$desc: res value"); |
358 | is($one, 'abcd', "$desc: \$1 value"); | |
359 | ||
360 | $desc = "match /g with pattern tainted, list cxt"; | |
361 | ||
362 | $s = 'abcd'; | |
363 | ($res, $res2) = $s =~ /$TAINT(.)/g; | |
364 | $one = $1; | |
f37ea7f0 NC |
365 | isnt_tainted($s, "$desc: s not tainted"); |
366 | is_tainted($res, "$desc: res tainted"); | |
367 | is_tainted($one, "$desc: \$1 tainted"); | |
c769ddc7 DM |
368 | is($res, 'a', "$desc: res value"); |
369 | is($res2,'b', "$desc: res2 value"); | |
370 | is($one, 'd', "$desc: \$1 value"); | |
371 | ||
569f7fc5 | 372 | SKIP: { |
ef9d5242 | 373 | skip 'Locales not available', 12 unless locales_enabled('LC_CTYPE'); |
c769ddc7 | 374 | |
569f7fc5 | 375 | $desc = "match with pattern tainted via locale, list cxt"; |
c769ddc7 | 376 | |
569f7fc5 JR |
377 | $s = 'abcd'; |
378 | { | |
5f1269ab | 379 | use locale; |
569f7fc5 JR |
380 | ($res) = $s =~ /(\w+)/; $one = $1; |
381 | } | |
382 | isnt_tainted($s, "$desc: s not tainted"); | |
383 | is_tainted($res, "$desc: res tainted"); | |
384 | is_tainted($one, "$desc: \$1 tainted"); | |
385 | is($res, 'abcd', "$desc: res value"); | |
386 | is($one, 'abcd', "$desc: \$1 value"); | |
387 | ||
388 | $desc = "match /g with pattern tainted via locale, list cxt"; | |
389 | ||
390 | $s = 'abcd'; | |
391 | { | |
5f1269ab | 392 | use locale; |
569f7fc5 JR |
393 | ($res, $res2) = $s =~ /(\w)/g; $one = $1; |
394 | } | |
395 | isnt_tainted($s, "$desc: s not tainted"); | |
396 | is_tainted($res, "$desc: res tainted"); | |
397 | is_tainted($res2, "$desc: res2 tainted"); | |
398 | is_tainted($one, "$desc: \$1 tainted"); | |
399 | is($res, 'a', "$desc: res value"); | |
400 | is($res2,'b', "$desc: res2 value"); | |
401 | is($one, 'd', "$desc: \$1 value"); | |
402 | } | |
c769ddc7 DM |
403 | |
404 | $desc = "substitution with string tainted"; | |
405 | ||
406 | $s = 'abcd' . $TAINT; | |
407 | $res = $s =~ s/(.+)/xyz/; | |
408 | $one = $1; | |
f37ea7f0 NC |
409 | is_tainted($s, "$desc: s tainted"); |
410 | isnt_tainted($res, "$desc: res not tainted"); | |
411 | isnt_tainted($one, "$desc: \$1 not tainted"); | |
c769ddc7 DM |
412 | is($s, 'xyz', "$desc: s value"); |
413 | is($res, 1, "$desc: res value"); | |
414 | is($one, 'abcd', "$desc: \$1 value"); | |
415 | ||
416 | $desc = "substitution /g with string tainted"; | |
417 | ||
418 | $s = 'abcd' . $TAINT; | |
419 | $res = $s =~ s/(.)/x/g; | |
420 | $one = $1; | |
f37ea7f0 NC |
421 | is_tainted($s, "$desc: s tainted"); |
422 | is_tainted($res, "$desc: res tainted"); | |
423 | isnt_tainted($one, "$desc: \$1 not tainted"); | |
c769ddc7 DM |
424 | is($s, 'xxxx', "$desc: s value"); |
425 | is($res, 4, "$desc: res value"); | |
426 | is($one, 'd', "$desc: \$1 value"); | |
427 | ||
428 | $desc = "substitution /r with string tainted"; | |
429 | ||
430 | $s = 'abcd' . $TAINT; | |
431 | $res = $s =~ s/(.+)/xyz/r; | |
432 | $one = $1; | |
f37ea7f0 NC |
433 | is_tainted($s, "$desc: s tainted"); |
434 | is_tainted($res, "$desc: res tainted"); | |
435 | isnt_tainted($one, "$desc: \$1 not tainted"); | |
c769ddc7 DM |
436 | is($s, 'abcd', "$desc: s value"); |
437 | is($res, 'xyz', "$desc: res value"); | |
438 | is($one, 'abcd', "$desc: \$1 value"); | |
439 | ||
20be6587 DM |
440 | $desc = "substitution /e with string tainted"; |
441 | ||
442 | $s = 'abcd' . $TAINT; | |
443 | $one = ''; | |
444 | $res = $s =~ s{(.+)}{ | |
445 | $one = $one . "x"; # make sure code not tainted | |
f37ea7f0 | 446 | isnt_tainted($one, "$desc: code not tainted within /e"); |
20be6587 | 447 | $one = $1; |
f37ea7f0 | 448 | isnt_tainted($one, "$desc: \$1 not tainted within /e"); |
20be6587 DM |
449 | "xyz"; |
450 | }e; | |
451 | $one = $1; | |
f37ea7f0 NC |
452 | is_tainted($s, "$desc: s tainted"); |
453 | isnt_tainted($res, "$desc: res not tainted"); | |
454 | isnt_tainted($one, "$desc: \$1 not tainted"); | |
20be6587 DM |
455 | is($s, 'xyz', "$desc: s value"); |
456 | is($res, 1, "$desc: res value"); | |
457 | is($one, 'abcd', "$desc: \$1 value"); | |
458 | ||
c769ddc7 DM |
459 | $desc = "substitution with pattern tainted"; |
460 | ||
461 | $s = 'abcd'; | |
462 | $res = $s =~ s/$TAINT(.+)/xyz/; | |
463 | $one = $1; | |
f37ea7f0 NC |
464 | is_tainted($s, "$desc: s tainted"); |
465 | isnt_tainted($res, "$desc: res not tainted"); | |
466 | is_tainted($one, "$desc: \$1 tainted"); | |
c769ddc7 DM |
467 | is($s, 'xyz', "$desc: s value"); |
468 | is($res, 1, "$desc: res value"); | |
469 | is($one, 'abcd', "$desc: \$1 value"); | |
470 | ||
471 | $desc = "substitution /g with pattern tainted"; | |
472 | ||
473 | $s = 'abcd'; | |
474 | $res = $s =~ s/$TAINT(.)/x/g; | |
475 | $one = $1; | |
f37ea7f0 NC |
476 | is_tainted($s, "$desc: s tainted"); |
477 | is_tainted($res, "$desc: res tainted"); | |
478 | is_tainted($one, "$desc: \$1 tainted"); | |
c769ddc7 DM |
479 | is($s, 'xxxx', "$desc: s value"); |
480 | is($res, 4, "$desc: res value"); | |
481 | is($one, 'd', "$desc: \$1 value"); | |
482 | ||
20be6587 DM |
483 | $desc = "substitution /ge with pattern tainted"; |
484 | ||
485 | $s = 'abc'; | |
486 | { | |
487 | my $i = 0; | |
488 | my $j; | |
489 | $res = $s =~ s{(.)$TAINT}{ | |
490 | $j = $i; # make sure code not tainted | |
491 | $one = $1; | |
f37ea7f0 | 492 | isnt_tainted($j, "$desc: code not tainted within /e"); |
20be6587 DM |
493 | $i++; |
494 | if ($i == 1) { | |
f37ea7f0 | 495 | isnt_tainted($s, "$desc: s not tainted loop 1"); |
20be6587 DM |
496 | } |
497 | else { | |
f37ea7f0 | 498 | is_tainted($s, "$desc: s tainted loop $i"); |
20be6587 | 499 | } |
f37ea7f0 | 500 | is_tainted($one, "$desc: \$1 tainted loop $i"); |
20be6587 DM |
501 | $i.$TAINT; |
502 | }ge; | |
503 | $one = $1; | |
504 | } | |
f37ea7f0 NC |
505 | is_tainted($s, "$desc: s tainted"); |
506 | is_tainted($res, "$desc: res tainted"); | |
507 | is_tainted($one, "$desc: \$1 tainted"); | |
20be6587 DM |
508 | is($s, '123', "$desc: s value"); |
509 | is($res, 3, "$desc: res value"); | |
510 | is($one, 'c', "$desc: \$1 value"); | |
511 | ||
c769ddc7 DM |
512 | $desc = "substitution /r with pattern tainted"; |
513 | ||
514 | $s = 'abcd'; | |
515 | $res = $s =~ s/$TAINT(.+)/xyz/r; | |
516 | $one = $1; | |
f37ea7f0 NC |
517 | isnt_tainted($s, "$desc: s not tainted"); |
518 | is_tainted($res, "$desc: res tainted"); | |
519 | is_tainted($one, "$desc: \$1 tainted"); | |
c769ddc7 DM |
520 | is($s, 'abcd', "$desc: s value"); |
521 | is($res, 'xyz', "$desc: res value"); | |
522 | is($one, 'abcd', "$desc: \$1 value"); | |
523 | ||
569f7fc5 | 524 | SKIP: { |
ef9d5242 | 525 | skip 'Locales not available', 18 unless locales_enabled('LC_CTYPE'); |
c769ddc7 | 526 | |
569f7fc5 | 527 | $desc = "substitution with pattern tainted via locale"; |
c769ddc7 | 528 | |
569f7fc5 JR |
529 | $s = 'abcd'; |
530 | { | |
5f1269ab | 531 | use locale; |
569f7fc5 JR |
532 | $res = $s =~ s/(\w+)/xyz/; $one = $1; |
533 | } | |
534 | is_tainted($s, "$desc: s tainted"); | |
535 | isnt_tainted($res, "$desc: res not tainted"); | |
536 | is_tainted($one, "$desc: \$1 tainted"); | |
537 | is($s, 'xyz', "$desc: s value"); | |
538 | is($res, 1, "$desc: res value"); | |
539 | is($one, 'abcd', "$desc: \$1 value"); | |
540 | ||
541 | $desc = "substitution /g with pattern tainted via locale"; | |
542 | ||
543 | $s = 'abcd'; | |
544 | { | |
5f1269ab | 545 | use locale; |
569f7fc5 JR |
546 | $res = $s =~ s/(\w)/x/g; $one = $1; |
547 | } | |
548 | is_tainted($s, "$desc: s tainted"); | |
549 | is_tainted($res, "$desc: res tainted"); | |
550 | is_tainted($one, "$desc: \$1 tainted"); | |
551 | is($s, 'xxxx', "$desc: s value"); | |
552 | is($res, 4, "$desc: res value"); | |
553 | is($one, 'd', "$desc: \$1 value"); | |
554 | ||
555 | $desc = "substitution /r with pattern tainted via locale"; | |
556 | ||
557 | $s = 'abcd'; | |
558 | { | |
5f1269ab | 559 | use locale; |
569f7fc5 JR |
560 | $res = $s =~ s/(\w+)/xyz/r; $one = $1; |
561 | } | |
562 | isnt_tainted($s, "$desc: s not tainted"); | |
563 | is_tainted($res, "$desc: res tainted"); | |
564 | is_tainted($one, "$desc: \$1 tainted"); | |
565 | is($s, 'abcd', "$desc: s value"); | |
566 | is($res, 'xyz', "$desc: res value"); | |
567 | is($one, 'abcd', "$desc: \$1 value"); | |
568 | } | |
c769ddc7 | 569 | |
c4f4b223 | 570 | $desc = "substitution with partial replacement tainted"; |
c769ddc7 DM |
571 | |
572 | $s = 'abcd'; | |
573 | $res = $s =~ s/(.+)/xyz$TAINT/; | |
574 | $one = $1; | |
f37ea7f0 NC |
575 | is_tainted($s, "$desc: s tainted"); |
576 | isnt_tainted($res, "$desc: res not tainted"); | |
577 | isnt_tainted($one, "$desc: \$1 not tainted"); | |
c769ddc7 DM |
578 | is($s, 'xyz', "$desc: s value"); |
579 | is($res, 1, "$desc: res value"); | |
580 | is($one, 'abcd', "$desc: \$1 value"); | |
581 | ||
c4f4b223 | 582 | $desc = "substitution /g with partial replacement tainted"; |
c769ddc7 DM |
583 | |
584 | $s = 'abcd'; | |
585 | $res = $s =~ s/(.)/x$TAINT/g; | |
586 | $one = $1; | |
f37ea7f0 NC |
587 | is_tainted($s, "$desc: s tainted"); |
588 | isnt_tainted($res, "$desc: res not tainted"); | |
589 | isnt_tainted($one, "$desc: \$1 not tainted"); | |
c769ddc7 DM |
590 | is($s, 'xxxx', "$desc: s value"); |
591 | is($res, 4, "$desc: res value"); | |
592 | is($one, 'd', "$desc: \$1 value"); | |
593 | ||
c4f4b223 | 594 | $desc = "substitution /ge with partial replacement tainted"; |
20be6587 DM |
595 | |
596 | $s = 'abc'; | |
597 | { | |
598 | my $i = 0; | |
599 | my $j; | |
600 | $res = $s =~ s{(.)}{ | |
601 | $j = $i; # make sure code not tainted | |
602 | $one = $1; | |
f37ea7f0 | 603 | isnt_tainted($j, "$desc: code not tainted within /e"); |
20be6587 DM |
604 | $i++; |
605 | if ($i == 1) { | |
f37ea7f0 | 606 | isnt_tainted($s, "$desc: s not tainted loop 1"); |
20be6587 DM |
607 | } |
608 | else { | |
f37ea7f0 | 609 | is_tainted($s, "$desc: s tainted loop $i"); |
20be6587 | 610 | } |
f37ea7f0 | 611 | isnt_tainted($one, "$desc: \$1 not tainted within /e"); |
20be6587 DM |
612 | $i.$TAINT; |
613 | }ge; | |
614 | $one = $1; | |
615 | } | |
f37ea7f0 | 616 | is_tainted($s, "$desc: s tainted"); |
52c47e16 | 617 | isnt_tainted($res, "$desc: res tainted"); |
f37ea7f0 | 618 | isnt_tainted($one, "$desc: \$1 not tainted"); |
20be6587 DM |
619 | is($s, '123', "$desc: s value"); |
620 | is($res, 3, "$desc: res value"); | |
621 | is($one, 'c', "$desc: \$1 value"); | |
622 | ||
c4f4b223 | 623 | $desc = "substitution /r with partial replacement tainted"; |
c769ddc7 DM |
624 | |
625 | $s = 'abcd'; | |
626 | $res = $s =~ s/(.+)/xyz$TAINT/r; | |
627 | $one = $1; | |
f37ea7f0 NC |
628 | isnt_tainted($s, "$desc: s not tainted"); |
629 | is_tainted($res, "$desc: res tainted"); | |
630 | isnt_tainted($one, "$desc: \$1 not tainted"); | |
c769ddc7 DM |
631 | is($s, 'abcd', "$desc: s value"); |
632 | is($res, 'xyz', "$desc: res value"); | |
633 | is($one, 'abcd', "$desc: \$1 value"); | |
1e422769 | 634 | |
c4f4b223 Z |
635 | $desc = "substitution with whole replacement tainted"; |
636 | ||
637 | $s = 'abcd'; | |
638 | $res = $s =~ s/(.+)/$TAINTXYZ/; | |
639 | $one = $1; | |
640 | is_tainted($s, "$desc: s tainted"); | |
641 | isnt_tainted($res, "$desc: res not tainted"); | |
642 | isnt_tainted($one, "$desc: \$1 not tainted"); | |
643 | is($s, 'xyz', "$desc: s value"); | |
644 | is($res, 1, "$desc: res value"); | |
645 | is($one, 'abcd', "$desc: \$1 value"); | |
646 | ||
647 | $desc = "substitution /g with whole replacement tainted"; | |
648 | ||
649 | $s = 'abcd'; | |
650 | $res = $s =~ s/(.)/$TAINTXYZ/g; | |
651 | $one = $1; | |
652 | is_tainted($s, "$desc: s tainted"); | |
653 | isnt_tainted($res, "$desc: res not tainted"); | |
654 | isnt_tainted($one, "$desc: \$1 not tainted"); | |
655 | is($s, 'xyz' x 4, "$desc: s value"); | |
656 | is($res, 4, "$desc: res value"); | |
657 | is($one, 'd', "$desc: \$1 value"); | |
658 | ||
659 | $desc = "substitution /ge with whole replacement tainted"; | |
660 | ||
661 | $s = 'abc'; | |
662 | { | |
663 | my $i = 0; | |
664 | my $j; | |
665 | $res = $s =~ s{(.)}{ | |
666 | $j = $i; # make sure code not tainted | |
667 | $one = $1; | |
668 | isnt_tainted($j, "$desc: code not tainted within /e"); | |
669 | $i++; | |
670 | if ($i == 1) { | |
671 | isnt_tainted($s, "$desc: s not tainted loop 1"); | |
672 | } | |
673 | else { | |
674 | is_tainted($s, "$desc: s tainted loop $i"); | |
675 | } | |
676 | isnt_tainted($one, "$desc: \$1 not tainted within /e"); | |
677 | $TAINTXYZ; | |
678 | }ge; | |
679 | $one = $1; | |
680 | } | |
681 | is_tainted($s, "$desc: s tainted"); | |
682 | isnt_tainted($res, "$desc: res tainted"); | |
683 | isnt_tainted($one, "$desc: \$1 not tainted"); | |
684 | is($s, 'xyz' x 3, "$desc: s value"); | |
685 | is($res, 3, "$desc: res value"); | |
686 | is($one, 'c', "$desc: \$1 value"); | |
687 | ||
688 | $desc = "substitution /r with whole replacement tainted"; | |
689 | ||
690 | $s = 'abcd'; | |
691 | $res = $s =~ s/(.+)/$TAINTXYZ/r; | |
692 | $one = $1; | |
693 | isnt_tainted($s, "$desc: s not tainted"); | |
694 | is_tainted($res, "$desc: res tainted"); | |
695 | isnt_tainted($one, "$desc: \$1 not tainted"); | |
696 | is($s, 'abcd', "$desc: s value"); | |
697 | is($res, 'xyz', "$desc: res value"); | |
698 | is($one, 'abcd', "$desc: \$1 value"); | |
699 | ||
b3eb6a9b | 700 | { |
c769ddc7 DM |
701 | # now do them all again with "use re 'taint" |
702 | ||
703 | use re 'taint'; | |
704 | ||
705 | $desc = "use re 'taint': match with string tainted"; | |
706 | ||
707 | $s = 'abcd' . $TAINT; | |
708 | $res = $s =~ /(.+)/; | |
709 | $one = $1; | |
f37ea7f0 NC |
710 | is_tainted($s, "$desc: s tainted"); |
711 | isnt_tainted($res, "$desc: res not tainted"); | |
712 | is_tainted($one, "$desc: \$1 tainted"); | |
c769ddc7 DM |
713 | is($res, 1, "$desc: res value"); |
714 | is($one, 'abcd', "$desc: \$1 value"); | |
715 | ||
716 | $desc = "use re 'taint': match /g with string tainted"; | |
717 | ||
718 | $s = 'abcd' . $TAINT; | |
719 | $res = $s =~ /(.)/g; | |
720 | $one = $1; | |
f37ea7f0 NC |
721 | is_tainted($s, "$desc: s tainted"); |
722 | isnt_tainted($res, "$desc: res not tainted"); | |
723 | is_tainted($one, "$desc: \$1 tainted"); | |
c769ddc7 DM |
724 | is($res, 1, "$desc: res value"); |
725 | is($one, 'a', "$desc: \$1 value"); | |
726 | ||
727 | $desc = "use re 'taint': match with string tainted, list cxt"; | |
728 | ||
729 | $s = 'abcd' . $TAINT; | |
730 | ($res) = $s =~ /(.+)/; | |
731 | $one = $1; | |
f37ea7f0 NC |
732 | is_tainted($s, "$desc: s tainted"); |
733 | is_tainted($res, "$desc: res tainted"); | |
734 | is_tainted($one, "$desc: \$1 tainted"); | |
c769ddc7 DM |
735 | is($res, 'abcd', "$desc: res value"); |
736 | is($one, 'abcd', "$desc: \$1 value"); | |
737 | ||
738 | $desc = "use re 'taint': match /g with string tainted, list cxt"; | |
739 | ||
740 | $s = 'abcd' . $TAINT; | |
741 | ($res, $res2) = $s =~ /(.)/g; | |
742 | $one = $1; | |
f37ea7f0 NC |
743 | is_tainted($s, "$desc: s tainted"); |
744 | is_tainted($res, "$desc: res tainted"); | |
745 | is_tainted($res2, "$desc: res2 tainted"); | |
746 | is_tainted($one, "$desc: \$1 not tainted"); | |
c769ddc7 DM |
747 | is($res, 'a', "$desc: res value"); |
748 | is($res2,'b', "$desc: res2 value"); | |
749 | is($one, 'd', "$desc: \$1 value"); | |
750 | ||
751 | $desc = "use re 'taint': match with pattern tainted"; | |
752 | ||
753 | $s = 'abcd'; | |
754 | $res = $s =~ /$TAINT(.+)/; | |
755 | $one = $1; | |
f37ea7f0 NC |
756 | isnt_tainted($s, "$desc: s not tainted"); |
757 | isnt_tainted($res, "$desc: res not tainted"); | |
758 | is_tainted($one, "$desc: \$1 tainted"); | |
c769ddc7 DM |
759 | is($res, 1, "$desc: res value"); |
760 | is($one, 'abcd', "$desc: \$1 value"); | |
761 | ||
762 | $desc = "use re 'taint': match /g with pattern tainted"; | |
763 | ||
764 | $s = 'abcd'; | |
765 | $res = $s =~ /$TAINT(.)/g; | |
766 | $one = $1; | |
f37ea7f0 NC |
767 | isnt_tainted($s, "$desc: s not tainted"); |
768 | isnt_tainted($res, "$desc: res not tainted"); | |
769 | is_tainted($one, "$desc: \$1 tainted"); | |
c769ddc7 DM |
770 | is($res, 1, "$desc: res value"); |
771 | is($one, 'a', "$desc: \$1 value"); | |
772 | ||
569f7fc5 | 773 | SKIP: { |
ef9d5242 | 774 | skip 'Locales not available', 10 unless locales_enabled('LC_CTYPE'); |
c769ddc7 | 775 | |
569f7fc5 | 776 | $desc = "use re 'taint': match with pattern tainted via locale"; |
c769ddc7 | 777 | |
569f7fc5 JR |
778 | $s = 'abcd'; |
779 | { | |
5f1269ab | 780 | use locale; |
569f7fc5 JR |
781 | $res = $s =~ /(\w+)/; $one = $1; |
782 | } | |
783 | isnt_tainted($s, "$desc: s not tainted"); | |
784 | isnt_tainted($res, "$desc: res not tainted"); | |
785 | is_tainted($one, "$desc: \$1 tainted"); | |
786 | is($res, 1, "$desc: res value"); | |
787 | is($one, 'abcd', "$desc: \$1 value"); | |
788 | ||
789 | $desc = "use re 'taint': match /g with pattern tainted via locale"; | |
790 | ||
791 | $s = 'abcd'; | |
792 | { | |
5f1269ab | 793 | use locale; |
569f7fc5 JR |
794 | $res = $s =~ /(\w)/g; $one = $1; |
795 | } | |
796 | isnt_tainted($s, "$desc: s not tainted"); | |
797 | isnt_tainted($res, "$desc: res not tainted"); | |
798 | is_tainted($one, "$desc: \$1 tainted"); | |
799 | is($res, 1, "$desc: res value"); | |
800 | is($one, 'a', "$desc: \$1 value"); | |
801 | } | |
c769ddc7 DM |
802 | |
803 | $desc = "use re 'taint': match with pattern tainted, list cxt"; | |
804 | ||
805 | $s = 'abcd'; | |
806 | ($res) = $s =~ /$TAINT(.+)/; | |
807 | $one = $1; | |
f37ea7f0 NC |
808 | isnt_tainted($s, "$desc: s not tainted"); |
809 | is_tainted($res, "$desc: res tainted"); | |
810 | is_tainted($one, "$desc: \$1 tainted"); | |
c769ddc7 DM |
811 | is($res, 'abcd', "$desc: res value"); |
812 | is($one, 'abcd', "$desc: \$1 value"); | |
813 | ||
814 | $desc = "use re 'taint': match /g with pattern tainted, list cxt"; | |
815 | ||
816 | $s = 'abcd'; | |
817 | ($res, $res2) = $s =~ /$TAINT(.)/g; | |
818 | $one = $1; | |
f37ea7f0 NC |
819 | isnt_tainted($s, "$desc: s not tainted"); |
820 | is_tainted($res, "$desc: res tainted"); | |
821 | is_tainted($one, "$desc: \$1 tainted"); | |
c769ddc7 DM |
822 | is($res, 'a', "$desc: res value"); |
823 | is($res2,'b', "$desc: res2 value"); | |
824 | is($one, 'd', "$desc: \$1 value"); | |
825 | ||
569f7fc5 | 826 | SKIP: { |
ef9d5242 | 827 | skip 'Locales not available', 12 unless locales_enabled('LC_CTYPE'); |
c769ddc7 | 828 | |
569f7fc5 | 829 | $desc = "use re 'taint': match with pattern tainted via locale, list cxt"; |
c769ddc7 | 830 | |
569f7fc5 JR |
831 | $s = 'abcd'; |
832 | { | |
5f1269ab | 833 | use locale; |
569f7fc5 JR |
834 | ($res) = $s =~ /(\w+)/; $one = $1; |
835 | } | |
836 | isnt_tainted($s, "$desc: s not tainted"); | |
837 | is_tainted($res, "$desc: res tainted"); | |
838 | is_tainted($one, "$desc: \$1 tainted"); | |
839 | is($res, 'abcd', "$desc: res value"); | |
840 | is($one, 'abcd', "$desc: \$1 value"); | |
841 | ||
842 | $desc = "use re 'taint': match /g with pattern tainted via locale, list cxt"; | |
843 | ||
844 | $s = 'abcd'; | |
845 | { | |
5f1269ab | 846 | use locale; |
569f7fc5 JR |
847 | ($res, $res2) = $s =~ /(\w)/g; $one = $1; |
848 | } | |
849 | isnt_tainted($s, "$desc: s not tainted"); | |
850 | is_tainted($res, "$desc: res tainted"); | |
851 | is_tainted($res2, "$desc: res2 tainted"); | |
852 | is_tainted($one, "$desc: \$1 tainted"); | |
853 | is($res, 'a', "$desc: res value"); | |
854 | is($res2,'b', "$desc: res2 value"); | |
855 | is($one, 'd', "$desc: \$1 value"); | |
856 | } | |
c769ddc7 DM |
857 | |
858 | $desc = "use re 'taint': substitution with string tainted"; | |
859 | ||
860 | $s = 'abcd' . $TAINT; | |
861 | $res = $s =~ s/(.+)/xyz/; | |
862 | $one = $1; | |
f37ea7f0 NC |
863 | is_tainted($s, "$desc: s tainted"); |
864 | isnt_tainted($res, "$desc: res not tainted"); | |
865 | is_tainted($one, "$desc: \$1 tainted"); | |
c769ddc7 DM |
866 | is($s, 'xyz', "$desc: s value"); |
867 | is($res, 1, "$desc: res value"); | |
868 | is($one, 'abcd', "$desc: \$1 value"); | |
869 | ||
870 | $desc = "use re 'taint': substitution /g with string tainted"; | |
871 | ||
872 | $s = 'abcd' . $TAINT; | |
873 | $res = $s =~ s/(.)/x/g; | |
874 | $one = $1; | |
f37ea7f0 NC |
875 | is_tainted($s, "$desc: s tainted"); |
876 | is_tainted($res, "$desc: res tainted"); | |
877 | is_tainted($one, "$desc: \$1 tainted"); | |
c769ddc7 DM |
878 | is($s, 'xxxx', "$desc: s value"); |
879 | is($res, 4, "$desc: res value"); | |
880 | is($one, 'd', "$desc: \$1 value"); | |
881 | ||
882 | $desc = "use re 'taint': substitution /r with string tainted"; | |
883 | ||
884 | $s = 'abcd' . $TAINT; | |
885 | $res = $s =~ s/(.+)/xyz/r; | |
886 | $one = $1; | |
f37ea7f0 NC |
887 | is_tainted($s, "$desc: s tainted"); |
888 | is_tainted($res, "$desc: res tainted"); | |
889 | is_tainted($one, "$desc: \$1 tainted"); | |
c769ddc7 DM |
890 | is($s, 'abcd', "$desc: s value"); |
891 | is($res, 'xyz', "$desc: res value"); | |
892 | is($one, 'abcd', "$desc: \$1 value"); | |
893 | ||
20be6587 DM |
894 | $desc = "use re 'taint': substitution /e with string tainted"; |
895 | ||
896 | $s = 'abcd' . $TAINT; | |
897 | $one = ''; | |
898 | $res = $s =~ s{(.+)}{ | |
899 | $one = $one . "x"; # make sure code not tainted | |
f37ea7f0 | 900 | isnt_tainted($one, "$desc: code not tainted within /e"); |
20be6587 | 901 | $one = $1; |
f37ea7f0 | 902 | is_tainted($one, "$desc: $1 tainted within /e"); |
20be6587 DM |
903 | "xyz"; |
904 | }e; | |
905 | $one = $1; | |
f37ea7f0 NC |
906 | is_tainted($s, "$desc: s tainted"); |
907 | isnt_tainted($res, "$desc: res not tainted"); | |
908 | is_tainted($one, "$desc: \$1 tainted"); | |
20be6587 DM |
909 | is($s, 'xyz', "$desc: s value"); |
910 | is($res, 1, "$desc: res value"); | |
911 | is($one, 'abcd', "$desc: \$1 value"); | |
912 | ||
c769ddc7 DM |
913 | $desc = "use re 'taint': substitution with pattern tainted"; |
914 | ||
915 | $s = 'abcd'; | |
916 | $res = $s =~ s/$TAINT(.+)/xyz/; | |
917 | $one = $1; | |
f37ea7f0 NC |
918 | is_tainted($s, "$desc: s tainted"); |
919 | isnt_tainted($res, "$desc: res not tainted"); | |
920 | is_tainted($one, "$desc: \$1 tainted"); | |
c769ddc7 DM |
921 | is($s, 'xyz', "$desc: s value"); |
922 | is($res, 1, "$desc: res value"); | |
923 | is($one, 'abcd', "$desc: \$1 value"); | |
924 | ||
925 | $desc = "use re 'taint': substitution /g with pattern tainted"; | |
926 | ||
927 | $s = 'abcd'; | |
928 | $res = $s =~ s/$TAINT(.)/x/g; | |
929 | $one = $1; | |
f37ea7f0 NC |
930 | is_tainted($s, "$desc: s tainted"); |
931 | is_tainted($res, "$desc: res tainted"); | |
932 | is_tainted($one, "$desc: \$1 tainted"); | |
c769ddc7 DM |
933 | is($s, 'xxxx', "$desc: s value"); |
934 | is($res, 4, "$desc: res value"); | |
935 | is($one, 'd', "$desc: \$1 value"); | |
936 | ||
20be6587 DM |
937 | $desc = "use re 'taint': substitution /ge with pattern tainted"; |
938 | ||
939 | $s = 'abc'; | |
940 | { | |
941 | my $i = 0; | |
942 | my $j; | |
943 | $res = $s =~ s{(.)$TAINT}{ | |
944 | $j = $i; # make sure code not tainted | |
945 | $one = $1; | |
f37ea7f0 | 946 | isnt_tainted($j, "$desc: code not tainted within /e"); |
20be6587 DM |
947 | $i++; |
948 | if ($i == 1) { | |
f37ea7f0 | 949 | isnt_tainted($s, "$desc: s not tainted loop 1"); |
20be6587 DM |
950 | } |
951 | else { | |
f37ea7f0 | 952 | is_tainted($s, "$desc: s tainted loop $i"); |
20be6587 | 953 | } |
f37ea7f0 | 954 | is_tainted($one, "$desc: \$1 tainted loop $i"); |
20be6587 DM |
955 | $i.$TAINT; |
956 | }ge; | |
957 | $one = $1; | |
958 | } | |
f37ea7f0 NC |
959 | is_tainted($s, "$desc: s tainted"); |
960 | is_tainted($res, "$desc: res tainted"); | |
961 | is_tainted($one, "$desc: \$1 tainted"); | |
20be6587 DM |
962 | is($s, '123', "$desc: s value"); |
963 | is($res, 3, "$desc: res value"); | |
964 | is($one, 'c', "$desc: \$1 value"); | |
965 | ||
966 | ||
c769ddc7 DM |
967 | $desc = "use re 'taint': substitution /r with pattern tainted"; |
968 | ||
969 | $s = 'abcd'; | |
970 | $res = $s =~ s/$TAINT(.+)/xyz/r; | |
971 | $one = $1; | |
f37ea7f0 NC |
972 | isnt_tainted($s, "$desc: s not tainted"); |
973 | is_tainted($res, "$desc: res tainted"); | |
974 | is_tainted($one, "$desc: \$1 tainted"); | |
c769ddc7 DM |
975 | is($s, 'abcd', "$desc: s value"); |
976 | is($res, 'xyz', "$desc: res value"); | |
977 | is($one, 'abcd', "$desc: \$1 value"); | |
978 | ||
569f7fc5 | 979 | SKIP: { |
ef9d5242 | 980 | skip 'Locales not available', 18 unless locales_enabled('LC_CTYPE'); |
c769ddc7 | 981 | |
569f7fc5 | 982 | $desc = "use re 'taint': substitution with pattern tainted via locale"; |
c769ddc7 | 983 | |
569f7fc5 JR |
984 | $s = 'abcd'; |
985 | { | |
5f1269ab | 986 | use locale; |
569f7fc5 JR |
987 | $res = $s =~ s/(\w+)/xyz/; $one = $1; |
988 | } | |
989 | is_tainted($s, "$desc: s tainted"); | |
990 | isnt_tainted($res, "$desc: res not tainted"); | |
991 | is_tainted($one, "$desc: \$1 tainted"); | |
992 | is($s, 'xyz', "$desc: s value"); | |
993 | is($res, 1, "$desc: res value"); | |
994 | is($one, 'abcd', "$desc: \$1 value"); | |
995 | ||
996 | $desc = "use re 'taint': substitution /g with pattern tainted via locale"; | |
997 | ||
998 | $s = 'abcd'; | |
999 | { | |
5f1269ab | 1000 | use locale; |
569f7fc5 JR |
1001 | $res = $s =~ s/(\w)/x/g; $one = $1; |
1002 | } | |
1003 | is_tainted($s, "$desc: s tainted"); | |
1004 | is_tainted($res, "$desc: res tainted"); | |
1005 | is_tainted($one, "$desc: \$1 tainted"); | |
1006 | is($s, 'xxxx', "$desc: s value"); | |
1007 | is($res, 4, "$desc: res value"); | |
1008 | is($one, 'd', "$desc: \$1 value"); | |
1009 | ||
1010 | $desc = "use re 'taint': substitution /r with pattern tainted via locale"; | |
1011 | ||
1012 | $s = 'abcd'; | |
1013 | { | |
5f1269ab | 1014 | use locale; |
569f7fc5 JR |
1015 | $res = $s =~ s/(\w+)/xyz/r; $one = $1; |
1016 | } | |
1017 | isnt_tainted($s, "$desc: s not tainted"); | |
1018 | is_tainted($res, "$desc: res tainted"); | |
1019 | is_tainted($one, "$desc: \$1 tainted"); | |
1020 | is($s, 'abcd', "$desc: s value"); | |
1021 | is($res, 'xyz', "$desc: res value"); | |
1022 | is($one, 'abcd', "$desc: \$1 value"); | |
1023 | } | |
c769ddc7 | 1024 | |
c4f4b223 | 1025 | $desc = "use re 'taint': substitution with partial replacement tainted"; |
c769ddc7 DM |
1026 | |
1027 | $s = 'abcd'; | |
1028 | $res = $s =~ s/(.+)/xyz$TAINT/; | |
1029 | $one = $1; | |
f37ea7f0 NC |
1030 | is_tainted($s, "$desc: s tainted"); |
1031 | isnt_tainted($res, "$desc: res not tainted"); | |
1032 | isnt_tainted($one, "$desc: \$1 not tainted"); | |
c769ddc7 DM |
1033 | is($s, 'xyz', "$desc: s value"); |
1034 | is($res, 1, "$desc: res value"); | |
1035 | is($one, 'abcd', "$desc: \$1 value"); | |
1036 | ||
c4f4b223 | 1037 | $desc = "use re 'taint': substitution /g with partial replacement tainted"; |
c769ddc7 DM |
1038 | |
1039 | $s = 'abcd'; | |
1040 | $res = $s =~ s/(.)/x$TAINT/g; | |
1041 | $one = $1; | |
f37ea7f0 NC |
1042 | is_tainted($s, "$desc: s tainted"); |
1043 | isnt_tainted($res, "$desc: res not tainted"); | |
1044 | isnt_tainted($one, "$desc: \$1 not tainted"); | |
c769ddc7 DM |
1045 | is($s, 'xxxx', "$desc: s value"); |
1046 | is($res, 4, "$desc: res value"); | |
1047 | is($one, 'd', "$desc: \$1 value"); | |
1048 | ||
c4f4b223 | 1049 | $desc = "use re 'taint': substitution /ge with partial replacement tainted"; |
20be6587 DM |
1050 | |
1051 | $s = 'abc'; | |
1052 | { | |
1053 | my $i = 0; | |
1054 | my $j; | |
1055 | $res = $s =~ s{(.)}{ | |
1056 | $j = $i; # make sure code not tainted | |
1057 | $one = $1; | |
f37ea7f0 | 1058 | isnt_tainted($j, "$desc: code not tainted within /e"); |
20be6587 DM |
1059 | $i++; |
1060 | if ($i == 1) { | |
f37ea7f0 | 1061 | isnt_tainted($s, "$desc: s not tainted loop 1"); |
20be6587 DM |
1062 | } |
1063 | else { | |
f37ea7f0 | 1064 | is_tainted($s, "$desc: s tainted loop $i"); |
20be6587 | 1065 | } |
f37ea7f0 | 1066 | isnt_tainted($one, "$desc: \$1 not tainted"); |
20be6587 DM |
1067 | $i.$TAINT; |
1068 | }ge; | |
1069 | $one = $1; | |
1070 | } | |
f37ea7f0 | 1071 | is_tainted($s, "$desc: s tainted"); |
52c47e16 | 1072 | isnt_tainted($res, "$desc: res tainted"); |
f37ea7f0 | 1073 | isnt_tainted($one, "$desc: \$1 not tainted"); |
20be6587 DM |
1074 | is($s, '123', "$desc: s value"); |
1075 | is($res, 3, "$desc: res value"); | |
1076 | is($one, 'c', "$desc: \$1 value"); | |
1077 | ||
c4f4b223 | 1078 | $desc = "use re 'taint': substitution /r with partial replacement tainted"; |
c769ddc7 DM |
1079 | |
1080 | $s = 'abcd'; | |
1081 | $res = $s =~ s/(.+)/xyz$TAINT/r; | |
1082 | $one = $1; | |
f37ea7f0 NC |
1083 | isnt_tainted($s, "$desc: s not tainted"); |
1084 | is_tainted($res, "$desc: res tainted"); | |
1085 | isnt_tainted($one, "$desc: \$1 not tainted"); | |
c769ddc7 DM |
1086 | is($s, 'abcd', "$desc: s value"); |
1087 | is($res, 'xyz', "$desc: res value"); | |
1088 | is($one, 'abcd', "$desc: \$1 value"); | |
1738e041 | 1089 | |
c4f4b223 Z |
1090 | $desc = "use re 'taint': substitution with whole replacement tainted"; |
1091 | ||
1092 | $s = 'abcd'; | |
1093 | $res = $s =~ s/(.+)/$TAINTXYZ/; | |
1094 | $one = $1; | |
1095 | is_tainted($s, "$desc: s tainted"); | |
1096 | isnt_tainted($res, "$desc: res not tainted"); | |
1097 | isnt_tainted($one, "$desc: \$1 not tainted"); | |
1098 | is($s, 'xyz', "$desc: s value"); | |
1099 | is($res, 1, "$desc: res value"); | |
1100 | is($one, 'abcd', "$desc: \$1 value"); | |
1101 | ||
1102 | $desc = "use re 'taint': substitution /g with whole replacement tainted"; | |
1103 | ||
1104 | $s = 'abcd'; | |
1105 | $res = $s =~ s/(.)/$TAINTXYZ/g; | |
1106 | $one = $1; | |
1107 | is_tainted($s, "$desc: s tainted"); | |
1108 | isnt_tainted($res, "$desc: res not tainted"); | |
1109 | isnt_tainted($one, "$desc: \$1 not tainted"); | |
1110 | is($s, 'xyz' x 4, "$desc: s value"); | |
1111 | is($res, 4, "$desc: res value"); | |
1112 | is($one, 'd', "$desc: \$1 value"); | |
1113 | ||
1114 | $desc = "use re 'taint': substitution /ge with whole replacement tainted"; | |
1115 | ||
1116 | $s = 'abc'; | |
1117 | { | |
1118 | my $i = 0; | |
1119 | my $j; | |
1120 | $res = $s =~ s{(.)}{ | |
1121 | $j = $i; # make sure code not tainted | |
1122 | $one = $1; | |
1123 | isnt_tainted($j, "$desc: code not tainted within /e"); | |
1124 | $i++; | |
1125 | if ($i == 1) { | |
1126 | isnt_tainted($s, "$desc: s not tainted loop 1"); | |
1127 | } | |
1128 | else { | |
1129 | is_tainted($s, "$desc: s tainted loop $i"); | |
1130 | } | |
1131 | isnt_tainted($one, "$desc: \$1 not tainted"); | |
1132 | $TAINTXYZ; | |
1133 | }ge; | |
1134 | $one = $1; | |
1135 | } | |
1136 | is_tainted($s, "$desc: s tainted"); | |
1137 | isnt_tainted($res, "$desc: res tainted"); | |
1138 | isnt_tainted($one, "$desc: \$1 not tainted"); | |
1139 | is($s, 'xyz' x 3, "$desc: s value"); | |
1140 | is($res, 3, "$desc: res value"); | |
1141 | is($one, 'c', "$desc: \$1 value"); | |
1142 | ||
1143 | $desc = "use re 'taint': substitution /r with whole replacement tainted"; | |
1144 | ||
1145 | $s = 'abcd'; | |
1146 | $res = $s =~ s/(.+)/$TAINTXYZ/r; | |
1147 | $one = $1; | |
1148 | isnt_tainted($s, "$desc: s not tainted"); | |
1149 | is_tainted($res, "$desc: res tainted"); | |
1150 | isnt_tainted($one, "$desc: \$1 not tainted"); | |
1151 | is($s, 'abcd', "$desc: s value"); | |
1152 | is($res, 'xyz', "$desc: res value"); | |
1153 | is($one, 'abcd', "$desc: \$1 value"); | |
1154 | ||
1738e041 DM |
1155 | # [perl #121854] match taintedness became sticky |
1156 | # when one match has a taintess result, subseqent matches | |
1157 | # using the same pattern shouldn't necessarily be tainted | |
1158 | ||
1159 | { | |
1160 | my $f = sub { $_[0] =~ /(.*)/ or die; $1 }; | |
1161 | $res = $f->($TAINT); | |
1162 | is_tainted($res, "121854: res tainted"); | |
1163 | $res = $f->("abc"); | |
1164 | isnt_tainted($res, "121854: res not tainted"); | |
1165 | } | |
b3eb6a9b GS |
1166 | } |
1167 | ||
1168 | $foo = $1 if 'bar' =~ /(.+)$TAINT/; | |
f37ea7f0 | 1169 | is_tainted($foo); |
c3197de1 | 1170 | is($foo, 'bar'); |
48c036b1 | 1171 | |
1e422769 | 1172 | my $pi = 4 * atan2(1,1) + $TAINT0; |
f37ea7f0 | 1173 | is_tainted($pi); |
1e422769 | 1174 | |
1175 | ($pi) = $pi =~ /(\d+\.\d+)/; | |
f37ea7f0 | 1176 | isnt_tainted($pi); |
c3197de1 | 1177 | is(sprintf("%.5f", $pi), '3.14159'); |
1e422769 | 1178 | } |
1179 | ||
1180 | # How about command-line arguments? The problem is that we don't | |
1181 | # always get some, so we'll run another process with some. | |
dc459aad | 1182 | SKIP: { |
1ab9acc5 | 1183 | my $arg = tempfile(); |
22d7dfed NC |
1184 | open $fh, '>', $arg or die "Can't create $arg: $!"; |
1185 | print $fh q{ | |
1e422769 | 1186 | eval { join('', @ARGV), kill 0 }; |
1187 | exit 0 if $@ =~ /^Insecure dependency/; | |
1188 | print "# Oops: \$@ was [$@]\n"; | |
1189 | exit 1; | |
1190 | }; | |
22d7dfed | 1191 | close $fh or die "Can't close $arg: $!"; |
1e422769 | 1192 | print `$Invoke_Perl "-T" $arg and some suspect arguments`; |
c3197de1 | 1193 | is($?, 0, "Exited with status $?"); |
1e422769 | 1194 | unlink $arg; |
1195 | } | |
1196 | ||
1197 | # Reading from a file should be tainted | |
1198 | { | |
22d7dfed | 1199 | ok(open my $fh, '<', $TEST) or diag("Couldn't open '$TEST': $!"); |
e91a8fe5 | 1200 | binmode $fh; |
1e422769 | 1201 | my $block; |
22d7dfed NC |
1202 | sysread($fh, $block, 100); |
1203 | my $line = <$fh>; | |
1204 | close $fh; | |
f37ea7f0 NC |
1205 | is_tainted($block); |
1206 | is_tainted($line); | |
1e422769 | 1207 | } |
1208 | ||
1e422769 | 1209 | # Output of commands should be tainted |
1210 | { | |
1211 | my $foo = `$echo abc`; | |
f37ea7f0 | 1212 | is_tainted($foo); |
1e422769 | 1213 | } |
1214 | ||
1215 | # Certain system variables should be tainted | |
1216 | { | |
e75436bf NC |
1217 | is_tainted($^X); |
1218 | is_tainted($0); | |
1e422769 | 1219 | } |
1220 | ||
1221 | # Results of matching should all be untainted | |
1222 | { | |
1223 | my $foo = "abcdefghi" . $TAINT; | |
f37ea7f0 | 1224 | is_tainted($foo); |
1e422769 | 1225 | |
1226 | $foo =~ /def/; | |
81cba34d NC |
1227 | isnt_tainted($`); |
1228 | isnt_tainted($&); | |
1229 | isnt_tainted($'); | |
1e422769 | 1230 | |
1231 | $foo =~ /(...)(...)(...)/; | |
81cba34d NC |
1232 | isnt_tainted($1); |
1233 | isnt_tainted($2); | |
1234 | isnt_tainted($3); | |
1235 | isnt_tainted($+); | |
1e422769 | 1236 | |
1237 | my @bar = $foo =~ /(...)(...)(...)/; | |
81cba34d | 1238 | isnt_tainted($_) foreach @bar; |
1e422769 | 1239 | |
f37ea7f0 | 1240 | is_tainted($foo); # $foo should still be tainted! |
c3197de1 | 1241 | is($foo, "abcdefghi"); |
1e422769 | 1242 | } |
1243 | ||
1244 | # Operations which affect files can't use tainted data. | |
1245 | { | |
8184526b | 1246 | violates_taint(sub { chmod 0, $TAINT }, 'chmod'); |
1e422769 | 1247 | |
e2b4a08c NC |
1248 | SKIP: { |
1249 | skip "truncate() is not available", 2 unless $Config{d_truncate}; | |
1250 | ||
8184526b | 1251 | violates_taint(sub { truncate 'NoSuChFiLe', $TAINT0 }, 'truncate'); |
e2b4a08c | 1252 | } |
1e422769 | 1253 | |
8184526b NC |
1254 | violates_taint(sub { rename '', $TAINT }, 'rename'); |
1255 | violates_taint(sub { unlink $TAINT }, 'unlink'); | |
1256 | violates_taint(sub { utime $TAINT }, 'utime'); | |
48c036b1 | 1257 | |
09f04786 MS |
1258 | SKIP: { |
1259 | skip "chown() is not available", 2 unless $Config{d_chown}; | |
1e422769 | 1260 | |
8184526b | 1261 | violates_taint(sub { chown -1, -1, $TAINT }, 'chown'); |
1e422769 | 1262 | } |
1263 | ||
09f04786 MS |
1264 | SKIP: { |
1265 | skip "link() is not available", 2 unless $Config{d_link}; | |
1266 | ||
8184526b | 1267 | violates_taint(sub { link $TAINT, '' }, 'link'); |
1e422769 | 1268 | } |
09f04786 MS |
1269 | |
1270 | SKIP: { | |
1271 | skip "symlink() is not available", 2 unless $Config{d_symlink}; | |
1272 | ||
8184526b | 1273 | violates_taint(sub { symlink $TAINT, '' }, 'symlink'); |
1e422769 | 1274 | } |
1275 | } | |
1276 | ||
1277 | # Operations which affect directories can't use tainted data. | |
1278 | { | |
8184526b NC |
1279 | violates_taint(sub { mkdir "foo".$TAINT, 0755 . $TAINT0 }, 'mkdir'); |
1280 | violates_taint(sub { rmdir $TAINT }, 'rmdir'); | |
1281 | violates_taint(sub { chdir "foo".$TAINT }, 'chdir'); | |
48c036b1 | 1282 | |
09f04786 MS |
1283 | SKIP: { |
1284 | skip "chroot() is not available", 2 unless $Config{d_chroot}; | |
1285 | ||
8184526b | 1286 | violates_taint(sub { chroot $TAINT }, 'chroot'); |
1e422769 | 1287 | } |
1288 | } | |
1289 | ||
1290 | # Some operations using files can't use tainted data. | |
1291 | { | |
1292 | my $foo = "imaginary library" . $TAINT; | |
8184526b | 1293 | violates_taint(sub { require $foo }, 'require'); |
33fe1955 | 1294 | violates_taint(sub { do $foo }, 'do'); |
1e422769 | 1295 | |
1c25d394 | 1296 | my $filename = tempfile(); # NB: $filename isn't tainted! |
1e422769 | 1297 | $foo = $filename . $TAINT; |
1298 | unlink $filename; # in any case | |
1299 | ||
c3197de1 | 1300 | is(eval { open FOO, $foo }, undef, 'open for read'); |
8184526b | 1301 | is($@, ''); # NB: This should be allowed |
22d7dfed NC |
1302 | is(eval { open my $fh, , '<', $foo }, undef, 'open for read'); |
1303 | is($@, ''); # NB: This should be allowed | |
9d116dd7 JH |
1304 | |
1305 | # Try first new style but allow also old style. | |
327ccce1 YST |
1306 | # We do not want the whole taint.t to fail |
1307 | # just because Errno possibly failing. | |
c3197de1 | 1308 | ok(eval('$!{ENOENT}') || |
61ae2fbf | 1309 | $! == 2 || # File not found |
c3197de1 | 1310 | ($Is_Dos && $! == 22)); |
1e422769 | 1311 | |
ef5cbc63 | 1312 | violates_taint(sub { open FOO, "> $foo" }, 'open', 'open for write'); |
22d7dfed | 1313 | violates_taint(sub { open my $fh, '>', $foo }, 'open', 'open for write'); |
1e422769 | 1314 | } |
1315 | ||
1316 | # Commands to the system can't use tainted data | |
1317 | { | |
1318 | my $foo = $TAINT; | |
1319 | ||
09f04786 | 1320 | SKIP: { |
22d7dfed | 1321 | skip "open('|') is not available", 8 if $^O eq 'amigaos'; |
09f04786 | 1322 | |
22d7dfed NC |
1323 | violates_taint(sub { open FOO, "| x$foo" }, 'piped open', 'popen to'); |
1324 | violates_taint(sub { open FOO, "x$foo |" }, 'piped open', 'popen from'); | |
1325 | violates_taint(sub { open my $fh, '|-', "x$foo" }, 'piped open', 'popen to'); | |
1326 | violates_taint(sub { open my $fh, '-|', "x$foo" }, 'piped open', 'popen from'); | |
48c036b1 | 1327 | } |
1e422769 | 1328 | |
8184526b NC |
1329 | violates_taint(sub { exec $TAINT }, 'exec'); |
1330 | violates_taint(sub { system $TAINT }, 'system'); | |
48c036b1 | 1331 | |
1e422769 | 1332 | $foo = "*"; |
1333 | taint_these $foo; | |
1334 | ||
ef5cbc63 | 1335 | violates_taint(sub { `$echo 1$foo` }, '``', 'backticks'); |
1e422769 | 1336 | |
09f04786 MS |
1337 | SKIP: { |
1338 | # wildcard expansion doesn't invoke shell on VMS, so is safe | |
1339 | skip "This is not VMS", 2 unless $Is_VMS; | |
1340 | ||
c3197de1 NC |
1341 | isnt(join('', eval { glob $foo } ), '', 'globbing'); |
1342 | is($@, ''); | |
1e422769 | 1343 | } |
1344 | } | |
1345 | ||
1346 | # Operations which affect processes can't use tainted data. | |
1347 | { | |
8184526b | 1348 | violates_taint(sub { kill 0, $TAINT }, 'kill'); |
1e422769 | 1349 | |
09f04786 MS |
1350 | SKIP: { |
1351 | skip "setpgrp() is not available", 2 unless $Config{d_setpgrp}; | |
1e422769 | 1352 | |
8184526b | 1353 | violates_taint(sub { setpgrp 0, $TAINT0 }, 'setpgrp'); |
1e422769 | 1354 | } |
09f04786 MS |
1355 | |
1356 | SKIP: { | |
1357 | skip "setpriority() is not available", 2 unless $Config{d_setprior}; | |
1358 | ||
8184526b | 1359 | violates_taint(sub { setpriority 0, $TAINT0, $TAINT0 }, 'setpriority'); |
1e422769 | 1360 | } |
1361 | } | |
1362 | ||
1363 | # Some miscellaneous operations can't use tainted data. | |
1364 | { | |
09f04786 MS |
1365 | SKIP: { |
1366 | skip "syscall() is not available", 2 unless $Config{d_syscall}; | |
1367 | ||
8184526b | 1368 | violates_taint(sub { syscall $TAINT }, 'syscall'); |
1e422769 | 1369 | } |
1370 | ||
1371 | { | |
1372 | my $foo = "x" x 979; | |
1373 | taint_these $foo; | |
1374 | local *FOO; | |
1c25d394 | 1375 | my $temp = tempfile(); |
c3197de1 | 1376 | ok(open FOO, "> $temp") or diag("Couldn't open $temp for write: $!"); |
8184526b | 1377 | violates_taint(sub { ioctl FOO, $TAINT0, $foo }, 'ioctl'); |
1e422769 | 1378 | |
22d7dfed NC |
1379 | my $temp2 = tempfile(); |
1380 | ok(open my $fh, '>', $temp2) or diag("Couldn't open $temp2 for write: $!"); | |
1381 | violates_taint(sub { ioctl $fh, $TAINT0, $foo }, 'ioctl'); | |
1382 | ||
09f04786 | 1383 | SKIP: { |
22d7dfed | 1384 | skip "fcntl() is not available", 4 unless $Config{d_fcntl}; |
09f04786 | 1385 | |
8184526b | 1386 | violates_taint(sub { fcntl FOO, $TAINT0, $foo }, 'fcntl'); |
22d7dfed | 1387 | violates_taint(sub { fcntl $fh, $TAINT0, $foo }, 'fcntl'); |
1e422769 | 1388 | } |
1389 | ||
1390 | close FOO; | |
1391 | } | |
1392 | } | |
1393 | ||
9607fc9c | 1394 | # Some tests involving references |
1e422769 | 1395 | { |
1396 | my $foo = 'abc' . $TAINT; | |
1397 | my $fooref = \$foo; | |
f37ea7f0 NC |
1398 | isnt_tainted($fooref); |
1399 | is_tainted($$fooref); | |
1400 | is_tainted($foo); | |
1e422769 | 1401 | } |
54310121 | 1402 | |
1403 | # Some tests involving assignment | |
1404 | { | |
1405 | my $foo = $TAINT0; | |
1406 | my $bar = $foo; | |
e75436bf NC |
1407 | is_tainted($foo); |
1408 | is_tainted($bar); | |
f37ea7f0 NC |
1409 | is_tainted($foo = $bar); |
1410 | is_tainted($bar = $bar); | |
1411 | is_tainted($bar += $bar); | |
1412 | is_tainted($bar -= $bar); | |
1413 | is_tainted($bar *= $bar); | |
1414 | is_tainted($bar++); | |
1415 | is_tainted($bar /= $bar); | |
1416 | is_tainted($bar += 0); | |
1417 | is_tainted($bar -= 2); | |
1418 | is_tainted($bar *= -1); | |
1419 | is_tainted($bar /= 1); | |
1420 | is_tainted($bar--); | |
c3197de1 | 1421 | is($bar, 0); |
54310121 | 1422 | } |
a1f49e72 CS |
1423 | |
1424 | # Test assignment and return of lists | |
1425 | { | |
1426 | my @foo = ("A", "tainted" . $TAINT, "B"); | |
f37ea7f0 NC |
1427 | isnt_tainted($foo[0]); |
1428 | is_tainted( $foo[1]); | |
1429 | isnt_tainted($foo[2]); | |
a1f49e72 | 1430 | my @bar = @foo; |
f37ea7f0 NC |
1431 | isnt_tainted($bar[0]); |
1432 | is_tainted( $bar[1]); | |
1433 | isnt_tainted($bar[2]); | |
a1f49e72 | 1434 | my @baz = eval { "A", "tainted" . $TAINT, "B" }; |
f37ea7f0 NC |
1435 | isnt_tainted($baz[0]); |
1436 | is_tainted( $baz[1]); | |
1437 | isnt_tainted($baz[2]); | |
a1f49e72 | 1438 | my @plugh = eval q[ "A", "tainted" . $TAINT, "B" ]; |
f37ea7f0 NC |
1439 | isnt_tainted($plugh[0]); |
1440 | is_tainted( $plugh[1]); | |
1441 | isnt_tainted($plugh[2]); | |
a1f49e72 | 1442 | my $nautilus = sub { "A", "tainted" . $TAINT, "B" }; |
f37ea7f0 NC |
1443 | isnt_tainted(((&$nautilus)[0])); |
1444 | is_tainted( ((&$nautilus)[1])); | |
1445 | isnt_tainted(((&$nautilus)[2])); | |
a1f49e72 | 1446 | my @xyzzy = &$nautilus; |
f37ea7f0 NC |
1447 | isnt_tainted($xyzzy[0]); |
1448 | is_tainted( $xyzzy[1]); | |
1449 | isnt_tainted($xyzzy[2]); | |
a1f49e72 | 1450 | my $red_october = sub { return "A", "tainted" . $TAINT, "B" }; |
f37ea7f0 NC |
1451 | isnt_tainted(((&$red_october)[0])); |
1452 | is_tainted( ((&$red_october)[1])); | |
1453 | isnt_tainted(((&$red_october)[2])); | |
a1f49e72 | 1454 | my @corge = &$red_october; |
f37ea7f0 NC |
1455 | isnt_tainted($corge[0]); |
1456 | is_tainted( $corge[1]); | |
1457 | isnt_tainted($corge[2]); | |
a1f49e72 | 1458 | } |
fb73857a | 1459 | |
1460 | # Test for system/library calls returning string data of dubious origin. | |
1461 | { | |
1462 | # No reliable %Config check for getpw* | |
09f04786 | 1463 | SKIP: { |
f37ea7f0 | 1464 | skip "getpwent() is not available", 9 unless |
09f04786 MS |
1465 | eval { setpwent(); getpwent() }; |
1466 | ||
fb73857a | 1467 | setpwent(); |
1468 | my @getpwent = getpwent(); | |
1469 | die "getpwent: $!\n" unless (@getpwent); | |
f37ea7f0 NC |
1470 | isnt_tainted($getpwent[0]); |
1471 | is_tainted($getpwent[1]); | |
1472 | isnt_tainted($getpwent[2]); | |
1473 | isnt_tainted($getpwent[3]); | |
1474 | isnt_tainted($getpwent[4]); | |
1475 | isnt_tainted($getpwent[5]); | |
1476 | is_tainted($getpwent[6], 'ge?cos'); | |
1477 | isnt_tainted($getpwent[7]); | |
1478 | is_tainted($getpwent[8], 'shell'); | |
fb73857a | 1479 | endpwent(); |
fb73857a | 1480 | } |
1481 | ||
09f04786 MS |
1482 | SKIP: { |
1483 | # pretty hard to imagine not | |
1484 | skip "readdir() is not available", 1 unless $Config{d_readdir}; | |
1485 | ||
22d7dfed NC |
1486 | opendir my $dh, "op" or die "opendir: $!\n"; |
1487 | my $readdir = readdir $dh; | |
f37ea7f0 | 1488 | is_tainted($readdir); |
22d7dfed | 1489 | closedir $dh; |
fb73857a | 1490 | } |
1491 | ||
09f04786 MS |
1492 | SKIP: { |
1493 | skip "readlink() or symlink() is not available" unless | |
1494 | $Config{d_readlink} && $Config{d_symlink}; | |
1495 | ||
fb73857a | 1496 | my $symlink = "sl$$"; |
1497 | unlink($symlink); | |
dc459aad JH |
1498 | my $sl = "/something/naughty"; |
1499 | # it has to be a real path on Mac OS | |
dc459aad | 1500 | symlink($sl, $symlink) or die "symlink: $!\n"; |
fb73857a | 1501 | my $readlink = readlink($symlink); |
f37ea7f0 | 1502 | is_tainted($readlink); |
fb73857a | 1503 | unlink($symlink); |
fb73857a | 1504 | } |
1505 | } | |
1506 | ||
1507 | # test bitwise ops (regression bug) | |
1508 | { | |
1509 | my $why = "y"; | |
1510 | my $j = "x" | $why; | |
f37ea7f0 | 1511 | isnt_tainted($j); |
fb73857a | 1512 | $why = $TAINT."y"; |
1513 | $j = "x" | $why; | |
f37ea7f0 | 1514 | is_tainted( $j); |
fb73857a | 1515 | } |
1516 | ||
48c036b1 GS |
1517 | # test target of substitution (regression bug) |
1518 | { | |
1519 | my $why = $TAINT."y"; | |
1520 | $why =~ s/y/z/; | |
f37ea7f0 | 1521 | is_tainted( $why); |
48c036b1 GS |
1522 | |
1523 | my $z = "[z]"; | |
1524 | $why =~ s/$z/zee/; | |
f37ea7f0 | 1525 | is_tainted( $why); |
48c036b1 GS |
1526 | |
1527 | $why =~ s/e/'-'.$$/ge; | |
f37ea7f0 | 1528 | is_tainted( $why); |
48c036b1 | 1529 | } |
d929ce6f | 1530 | |
09f04786 MS |
1531 | |
1532 | SKIP: { | |
1533 | skip "no IPC::SysV", 2 unless $ipcsysv; | |
1534 | ||
1535 | # test shmread | |
1536 | SKIP: { | |
1537 | skip "shm*() not available", 1 unless $Config{d_shm}; | |
1538 | ||
1539 | no strict 'subs'; | |
1540 | my $sent = "foobar"; | |
1541 | my $rcvd; | |
1542 | my $size = 2000; | |
3383030d TC |
1543 | my $id; |
1544 | eval { | |
1545 | local $SIG{SYS} = sub { die "SIGSYS caught\n" }; | |
1546 | $id = shmget(IPC_PRIVATE, $size, S_IRWXU); | |
1547 | 1; | |
1548 | } or do { chomp(my $msg = $@); skip "shmget: $msg", 1; }; | |
09f04786 MS |
1549 | |
1550 | if (defined $id) { | |
1551 | if (shmwrite($id, $sent, 0, 60)) { | |
1552 | if (shmread($id, $rcvd, 0, 60)) { | |
1553 | substr($rcvd, index($rcvd, "\0")) = ''; | |
1554 | } else { | |
1555 | warn "# shmread failed: $!\n"; | |
1556 | } | |
1557 | } else { | |
1558 | warn "# shmwrite failed: $!\n"; | |
1559 | } | |
1560 | shmctl($id, IPC_RMID, 0) or warn "# shmctl failed: $!\n"; | |
1561 | } else { | |
1562 | warn "# shmget failed: $!\n"; | |
1563 | } | |
1564 | ||
1565 | skip "SysV shared memory operation failed", 1 unless | |
1566 | $rcvd eq $sent; | |
1567 | ||
3383030d | 1568 | is_tainted($rcvd, "shmread"); |
c9f931b8 | 1569 | } |
c2e66d9e | 1570 | |
d929ce6f | 1571 | |
09f04786 MS |
1572 | # test msgrcv |
1573 | SKIP: { | |
1574 | skip "msg*() not available", 1 unless $Config{d_msg}; | |
41d6edb2 | 1575 | |
b9d1c439 | 1576 | no strict 'subs'; |
3383030d TC |
1577 | my $id; |
1578 | eval { | |
1579 | local $SIG{SYS} = sub { die "SIGSYS caught\n" }; | |
1580 | $id = msgget(IPC_PRIVATE, IPC_CREAT | S_IRWXU); | |
1581 | 1; | |
1582 | } or do { chomp(my $msg = $@); skip "msgget: $msg", 1; }; | |
41d6edb2 JH |
1583 | |
1584 | my $sent = "message"; | |
1585 | my $type_sent = 1234; | |
1586 | my $rcvd; | |
1587 | my $type_rcvd; | |
1588 | ||
1589 | if (defined $id) { | |
ddc3217d JH |
1590 | if (msgsnd($id, pack("l! a*", $type_sent, $sent), IPC_NOWAIT)) { |
1591 | if (msgrcv($id, $rcvd, 60, 0, IPC_NOWAIT)) { | |
41d6edb2 JH |
1592 | ($type_rcvd, $rcvd) = unpack("l! a*", $rcvd); |
1593 | } else { | |
ddc3217d | 1594 | warn "# msgrcv failed: $!\n"; |
41d6edb2 JH |
1595 | } |
1596 | } else { | |
ddc3217d | 1597 | warn "# msgsnd failed: $!\n"; |
41d6edb2 | 1598 | } |
c2e66d9e | 1599 | msgctl($id, IPC_RMID, 0) or warn "# msgctl failed: $!\n"; |
41d6edb2 JH |
1600 | } else { |
1601 | warn "# msgget failed\n"; | |
1602 | } | |
1603 | ||
09f04786 MS |
1604 | SKIP: { |
1605 | skip "SysV message queue operation failed", 1 | |
1606 | unless $rcvd eq $sent && $type_sent == $type_rcvd; | |
1607 | ||
3383030d | 1608 | is_tainted($rcvd, "msgrcv"); |
41d6edb2 | 1609 | } |
41d6edb2 JH |
1610 | } |
1611 | } | |
1612 | ||
3887d568 | 1613 | { |
ee95e30c | 1614 | # bug id 20001004.006 (#4380) |
3887d568 | 1615 | |
22d7dfed | 1616 | open my $fh, '<', $TEST or warn "$0: cannot read $TEST: $!" ; |
3887d568 | 1617 | local $/; |
22d7dfed NC |
1618 | my $a = <$fh>; |
1619 | my $b = <$fh>; | |
09f04786 | 1620 | |
f37ea7f0 NC |
1621 | is_tainted($a); |
1622 | is_tainted($b); | |
1623 | is($b, undef); | |
3887d568 | 1624 | } |
27c9684d AP |
1625 | |
1626 | { | |
ee95e30c | 1627 | # bug id 20001004.007 (#4381) |
27c9684d | 1628 | |
22d7dfed NC |
1629 | open my $fh, '<', $TEST or warn "$0: cannot read $TEST: $!" ; |
1630 | my $a = <$fh>; | |
27c9684d AP |
1631 | |
1632 | my $c = { a => 42, | |
1633 | b => $a }; | |
09f04786 | 1634 | |
f37ea7f0 NC |
1635 | isnt_tainted($c->{a}); |
1636 | is_tainted($c->{b}); | |
09f04786 | 1637 | |
27c9684d AP |
1638 | |
1639 | my $d = { a => $a, | |
1640 | b => 42 }; | |
f37ea7f0 NC |
1641 | is_tainted($d->{a}); |
1642 | isnt_tainted($d->{b}); | |
09f04786 | 1643 | |
27c9684d AP |
1644 | |
1645 | my $e = { a => 42, | |
1646 | b => { c => $a, d => 42 } }; | |
f37ea7f0 NC |
1647 | isnt_tainted($e->{a}); |
1648 | isnt_tainted($e->{b}); | |
1649 | is_tainted($e->{b}->{c}); | |
1650 | isnt_tainted($e->{b}->{d}); | |
27c9684d AP |
1651 | } |
1652 | ||
b94c04ac | 1653 | { |
ee95e30c | 1654 | # bug id 20010519.003 (#7015) |
b94c04ac | 1655 | |
83461ff8 | 1656 | our $has_fcntl; |
248c32c0 | 1657 | BEGIN { |
248c32c0 JH |
1658 | eval { require Fcntl; import Fcntl; }; |
1659 | unless ($@) { | |
1660 | $has_fcntl = 1; | |
1661 | } | |
1662 | } | |
b94c04ac | 1663 | |
09f04786 | 1664 | SKIP: { |
51e97f47 | 1665 | skip "no Fcntl", 36 unless $has_fcntl; |
09f04786 | 1666 | |
281a340f NC |
1667 | my $foo = tempfile(); |
1668 | my $evil = $foo . $TAINT; | |
248c32c0 | 1669 | |
4e74b85b NC |
1670 | is(eval { sysopen(my $ro, $evil, &O_RDONLY) }, undef); |
1671 | is($@, ''); | |
1672 | ||
1673 | violates_taint(sub { sysopen(my $wo, $evil, &O_WRONLY) }, 'sysopen'); | |
1674 | violates_taint(sub { sysopen(my $rw, $evil, &O_RDWR) }, 'sysopen'); | |
1675 | violates_taint(sub { sysopen(my $ap, $evil, &O_APPEND) }, 'sysopen'); | |
1676 | violates_taint(sub { sysopen(my $cr, $evil, &O_CREAT) }, 'sysopen'); | |
1677 | violates_taint(sub { sysopen(my $tr, $evil, &O_TRUNC) }, 'sysopen'); | |
1678 | ||
1679 | is(eval { sysopen(my $ro, $foo, &O_RDONLY | $TAINT0) }, undef); | |
1680 | is($@, ''); | |
1681 | ||
1682 | violates_taint(sub { sysopen(my $wo, $foo, &O_WRONLY | $TAINT0) }, 'sysopen'); | |
1683 | violates_taint(sub { sysopen(my $rw, $foo, &O_RDWR | $TAINT0) }, 'sysopen'); | |
1684 | violates_taint(sub { sysopen(my $ap, $foo, &O_APPEND | $TAINT0) }, 'sysopen'); | |
1685 | violates_taint(sub { sysopen(my $cr, $foo, &O_CREAT | $TAINT0) }, 'sysopen'); | |
1686 | violates_taint(sub { sysopen(my $tr, $foo, &O_TRUNC | $TAINT0) }, 'sysopen'); | |
1687 | is(eval { sysopen(my $ro, $foo, &O_RDONLY, $TAINT0) }, undef); | |
1688 | is($@, ''); | |
1689 | ||
1690 | violates_taint(sub { sysopen(my $wo, $foo, &O_WRONLY, $TAINT0) }, 'sysopen'); | |
1691 | violates_taint(sub { sysopen(my $rw, $foo, &O_RDWR, $TAINT0) }, 'sysopen'); | |
1692 | violates_taint(sub { sysopen(my $ap, $foo, &O_APPEND, $TAINT0) }, 'sysopen'); | |
1693 | violates_taint(sub { sysopen(my $cr, $foo, &O_CREAT, $TAINT0) }, 'sysopen'); | |
1694 | violates_taint(sub { sysopen(my $tr, $foo, &O_TRUNC, $TAINT0) }, 'sysopen'); | |
248c32c0 | 1695 | } |
b94c04ac JH |
1696 | } |
1697 | ||
65811bc3 | 1698 | { |
ee95e30c | 1699 | # bug 20010526.004 (#7041) |
65811bc3 JH |
1700 | |
1701 | use warnings; | |
1702 | ||
09f04786 | 1703 | my $saw_warning = 0; |
c3197de1 | 1704 | local $SIG{__WARN__} = sub { ++$saw_warning }; |
65811bc3 JH |
1705 | |
1706 | sub fmi { | |
1707 | my $divnum = shift()/1; | |
1708 | sprintf("%1.1f\n", $divnum); | |
1709 | } | |
1710 | ||
1711 | fmi(21 . $TAINT); | |
1712 | fmi(37); | |
1713 | fmi(248); | |
1714 | ||
c3197de1 | 1715 | is($saw_warning, 0); |
65811bc3 JH |
1716 | } |
1717 | ||
9e1b5a4e A |
1718 | |
1719 | { | |
ee95e30c | 1720 | # Bug ID 20010730.010 (#7387) |
9e1b5a4e A |
1721 | |
1722 | my $i = 0; | |
1723 | ||
1724 | sub Tie::TIESCALAR { | |
1725 | my $class = shift; | |
1726 | my $arg = shift; | |
1727 | ||
1728 | bless \$arg => $class; | |
1729 | } | |
1730 | ||
1731 | sub Tie::FETCH { | |
1732 | $i ++; | |
1733 | ${$_ [0]} | |
1734 | } | |
1735 | ||
1736 | ||
1737 | package main; | |
1738 | ||
1739 | my $bar = "The Big Bright Green Pleasure Machine"; | |
1740 | taint_these $bar; | |
1741 | tie my ($foo), Tie => $bar; | |
1742 | ||
1743 | my $baz = $foo; | |
1744 | ||
09f04786 | 1745 | ok $i == 1; |
9e1b5a4e A |
1746 | } |
1747 | ||
8852b6d2 JH |
1748 | { |
1749 | # Check that all environment variables are tainted. | |
1750 | my @untainted; | |
1751 | while (my ($k, $v) = each %ENV) { | |
1752 | if (!tainted($v) && | |
eb25aaf6 HS |
1753 | # These we have explicitly untainted or set earlier. |
1754 | $k !~ /^(BASH_ENV|CDPATH|ENV|IFS|PATH|PERL_CORE|TEMP|TERM|TMP)$/) { | |
8852b6d2 JH |
1755 | push @untainted, "# '$k' = '$v'\n"; |
1756 | } | |
1757 | } | |
c3197de1 | 1758 | is("@untainted", ""); |
8852b6d2 | 1759 | } |
9e1b5a4e A |
1760 | |
1761 | ||
433f4d03 | 1762 | is(${^TAINT}, 1, '$^TAINT is on'); |
7c36658b MS |
1763 | |
1764 | eval { ${^TAINT} = 0 }; | |
433f4d03 NC |
1765 | is(${^TAINT}, 1, '$^TAINT is not assignable'); |
1766 | like($@, qr/^Modification of a read-only value attempted/, | |
1767 | 'Assigning to ${^TAINT} fails'); | |
7c36658b | 1768 | |
e08e52cf | 1769 | { |
ee95e30c | 1770 | # bug 20011111.105 (#7897) |
e08e52cf AMS |
1771 | |
1772 | my $re1 = qr/x$TAINT/; | |
f37ea7f0 | 1773 | is_tainted($re1); |
e08e52cf AMS |
1774 | |
1775 | my $re2 = qr/^$re1\z/; | |
f37ea7f0 | 1776 | is_tainted($re2); |
e08e52cf AMS |
1777 | |
1778 | my $re3 = "$re2"; | |
f37ea7f0 | 1779 | is_tainted($re3); |
e08e52cf | 1780 | } |
52a55424 | 1781 | |
09f04786 MS |
1782 | SKIP: { |
1783 | skip "system {} has different semantics on Win32", 1 if $Is_MSWin32; | |
1784 | ||
ee95e30c | 1785 | # bug 20010221.005 (#5882) |
52a55424 RG |
1786 | local $ENV{PATH} .= $TAINT; |
1787 | eval { system { "echo" } "/arg0", "arg1" }; | |
c3197de1 | 1788 | like($@, qr/^Insecure \$ENV/); |
52a55424 | 1789 | } |
09f04786 MS |
1790 | |
1791 | TODO: { | |
1792 | todo_skip 'tainted %ENV warning occludes tainted arguments warning', 22 | |
1793 | if $Is_VMS; | |
1794 | ||
ee95e30c | 1795 | # bug 20020208.005 (#8465) plus some single arg exec/system extras |
8184526b NC |
1796 | violates_taint(sub { exec $TAINT, $TAINT }, 'exec'); |
1797 | violates_taint(sub { exec $TAINT $TAINT }, 'exec'); | |
1798 | violates_taint(sub { exec $TAINT $TAINT, $TAINT }, 'exec'); | |
1799 | violates_taint(sub { exec $TAINT 'notaint' }, 'exec'); | |
1800 | violates_taint(sub { exec {'notaint'} $TAINT }, 'exec'); | |
1801 | ||
1802 | violates_taint(sub { system $TAINT, $TAINT }, 'system'); | |
1803 | violates_taint(sub { system $TAINT $TAINT }, 'system'); | |
1804 | violates_taint(sub { system $TAINT $TAINT, $TAINT }, 'system'); | |
1805 | violates_taint(sub { system $TAINT 'notaint' }, 'system'); | |
1806 | violates_taint(sub { system {'notaint'} $TAINT }, 'system'); | |
09f04786 MS |
1807 | |
1808 | eval { | |
1809 | no warnings; | |
1810 | system("lskdfj does not exist","with","args"); | |
1811 | }; | |
c3197de1 | 1812 | is($@, ""); |
09f04786 | 1813 | |
7b903762 RGS |
1814 | eval { |
1815 | no warnings; | |
1816 | exec("lskdfj does not exist","with","args"); | |
1817 | }; | |
c3197de1 | 1818 | is($@, ""); |
6c8794e1 JH |
1819 | |
1820 | # If you add tests here update also the above skip block for VMS. | |
bbd7eb8a | 1821 | } |
a8c7c11a HS |
1822 | |
1823 | { | |
ee95e30c | 1824 | # [ID 20020704.001 (#10026)] taint propagation failure |
a8c7c11a HS |
1825 | use re 'taint'; |
1826 | $TAINT =~ /(.*)/; | |
f37ea7f0 | 1827 | is_tainted(my $foo = $1); |
a8c7c11a | 1828 | } |
7b756e0a RGS |
1829 | |
1830 | { | |
c038024b RGS |
1831 | # [perl #24291] this used to dump core |
1832 | our %nonmagicalenv = ( PATH => "util" ); | |
7b756e0a RGS |
1833 | local *ENV = \%nonmagicalenv; |
1834 | eval { system("lskdfj"); }; | |
c3197de1 | 1835 | like($@, qr/^%ENV is aliased to another variable while running with -T switch/); |
c038024b | 1836 | local *ENV = *nonmagicalenv; |
7b756e0a | 1837 | eval { system("lskdfj"); }; |
c3197de1 | 1838 | like($@, qr/^%ENV is aliased to %nonmagicalenv while running with -T switch/); |
7b756e0a | 1839 | } |
0b4182de RD |
1840 | { |
1841 | # [perl #24248] | |
1842 | $TAINT =~ /(.*)/; | |
f37ea7f0 | 1843 | isnt_tainted($1); |
0b4182de | 1844 | my $notaint = $1; |
f37ea7f0 | 1845 | isnt_tainted($notaint); |
0b4182de RD |
1846 | |
1847 | my $l; | |
1848 | $notaint =~ /($notaint)/; | |
1849 | $l = $1; | |
f37ea7f0 NC |
1850 | isnt_tainted($1); |
1851 | isnt_tainted($l); | |
0b4182de RD |
1852 | $notaint =~ /($TAINT)/; |
1853 | $l = $1; | |
f37ea7f0 NC |
1854 | is_tainted($1); |
1855 | is_tainted($l); | |
0b4182de RD |
1856 | |
1857 | $TAINT =~ /($notaint)/; | |
1858 | $l = $1; | |
f37ea7f0 NC |
1859 | isnt_tainted($1); |
1860 | isnt_tainted($l); | |
0b4182de RD |
1861 | $TAINT =~ /($TAINT)/; |
1862 | $l = $1; | |
f37ea7f0 NC |
1863 | is_tainted($1); |
1864 | is_tainted($l); | |
0b4182de RD |
1865 | |
1866 | my $r; | |
1867 | ($r = $TAINT) =~ /($notaint)/; | |
f37ea7f0 | 1868 | isnt_tainted($1); |
0b4182de | 1869 | ($r = $TAINT) =~ /($TAINT)/; |
f37ea7f0 | 1870 | is_tainted($1); |
3511154c | 1871 | |
7fb31b92 DM |
1872 | { |
1873 | use re 'eval'; # this shouldn't make any difference | |
1874 | ($r = $TAINT) =~ /($notaint)/; | |
1875 | isnt_tainted($1); | |
1876 | ($r = $TAINT) =~ /($TAINT)/; | |
1877 | is_tainted($1); | |
1878 | } | |
1879 | ||
3511154c DM |
1880 | # [perl #24674] |
1881 | # accessing $^O shoudn't taint it as a side-effect; | |
1882 | # assigning tainted data to it is now an error | |
1883 | ||
f37ea7f0 | 1884 | isnt_tainted($^O); |
3511154c | 1885 | if (!$^X) { } elsif ($^O eq 'bar') { } |
f37ea7f0 | 1886 | isnt_tainted($^O); |
4b24804c | 1887 | local $^O; # We're going to clobber something test infrastructure depends on. |
3511154c | 1888 | eval '$^O = $^X'; |
c3197de1 | 1889 | like($@, qr/Insecure dependency in/); |
0b4182de | 1890 | } |
23634c10 AL |
1891 | |
1892 | EFFECTIVELY_CONSTANTS: { | |
1893 | my $tainted_number = 12 + $TAINT0; | |
f37ea7f0 | 1894 | is_tainted( $tainted_number ); |
23634c10 AL |
1895 | |
1896 | # Even though it's always 0, it's still tainted | |
1897 | my $tainted_product = $tainted_number * 0; | |
f37ea7f0 | 1898 | is_tainted( $tainted_product ); |
c3197de1 | 1899 | is($tainted_product, 0); |
23634c10 AL |
1900 | } |
1901 | ||
1902 | TERNARY_CONDITIONALS: { | |
1903 | my $tainted_true = $TAINT . "blah blah blah"; | |
1904 | my $tainted_false = $TAINT0; | |
f37ea7f0 NC |
1905 | is_tainted( $tainted_true ); |
1906 | is_tainted( $tainted_false ); | |
23634c10 AL |
1907 | |
1908 | my $result = $tainted_true ? "True" : "False"; | |
c3197de1 | 1909 | is($result, "True"); |
f37ea7f0 | 1910 | isnt_tainted( $result ); |
23634c10 AL |
1911 | |
1912 | $result = $tainted_false ? "True" : "False"; | |
c3197de1 | 1913 | is($result, "False"); |
f37ea7f0 | 1914 | isnt_tainted( $result ); |
23634c10 AL |
1915 | |
1916 | my $untainted_whatever = "The Fabulous Johnny Cash"; | |
1917 | my $tainted_whatever = "Soft Cell" . $TAINT; | |
1918 | ||
1919 | $result = $tainted_true ? $tainted_whatever : $untainted_whatever; | |
c3197de1 | 1920 | is($result, "Soft Cell"); |
f37ea7f0 | 1921 | is_tainted( $result ); |
23634c10 AL |
1922 | |
1923 | $result = $tainted_false ? $tainted_whatever : $untainted_whatever; | |
c3197de1 | 1924 | is($result, "The Fabulous Johnny Cash"); |
f37ea7f0 | 1925 | isnt_tainted( $result ); |
23634c10 | 1926 | } |
65814f21 MS |
1927 | |
1928 | { | |
1929 | # rt.perl.org 5900 $1 remains tainted if... | |
1930 | # 1) The regular expression contains a scalar variable AND | |
1931 | # 2) The regular expression appears in an elsif clause | |
1932 | ||
1933 | my $foo = "abcdefghi" . $TAINT; | |
1934 | ||
1935 | my $valid_chars = 'a-z'; | |
1936 | if ( $foo eq '' ) { | |
1937 | } | |
1938 | elsif ( $foo =~ /([$valid_chars]+)/o ) { | |
81cba34d NC |
1939 | isnt_tainted($1); |
1940 | isnt($1, undef); | |
65814f21 MS |
1941 | } |
1942 | ||
1943 | if ( $foo eq '' ) { | |
1944 | } | |
1945 | elsif ( my @bar = $foo =~ /([$valid_chars]+)/o ) { | |
81cba34d NC |
1946 | isnt_tainted($bar[0]); |
1947 | is(scalar @bar, 1); | |
65814f21 MS |
1948 | } |
1949 | } | |
0a9c116b DM |
1950 | |
1951 | # at scope exit, a restored localised value should have its old | |
1952 | # taint status, not the taint status of the current statement | |
1953 | ||
1954 | { | |
1955 | our $x99 = $^X; | |
f37ea7f0 | 1956 | is_tainted($x99); |
0a9c116b DM |
1957 | |
1958 | $x99 = ''; | |
f37ea7f0 | 1959 | isnt_tainted($x99); |
0a9c116b DM |
1960 | |
1961 | my $c = do { local $x99; $^X }; | |
f37ea7f0 | 1962 | isnt_tainted($x99); |
0a9c116b DM |
1963 | } |
1964 | { | |
1965 | our $x99 = $^X; | |
f37ea7f0 | 1966 | is_tainted($x99); |
0a9c116b DM |
1967 | |
1968 | my $c = do { local $x99; '' }; | |
f37ea7f0 | 1969 | is_tainted($x99); |
0a9c116b DM |
1970 | } |
1971 | ||
27cc343c DM |
1972 | # an mg_get of a tainted value during localization shouldn't taint the |
1973 | # statement | |
1974 | ||
1975 | { | |
1976 | eval { local $0, eval '1' }; | |
c3197de1 | 1977 | is($@, ''); |
27cc343c | 1978 | } |
e26a4975 DM |
1979 | |
1980 | # [perl #8262] //g loops infinitely on tainted data | |
1981 | ||
1982 | { | |
1983 | my @a; | |
fd69380d DM |
1984 | $a[0] = $^X . '-'; |
1985 | $a[0]=~ m/(.)/g; | |
1986 | cmp_ok pos($a[0]), '>', 0, "infinite m//g on arrays (aelemfast)"; | |
1987 | ||
1988 | my $i = 1; | |
1989 | $a[$i] = $^X . '-'; | |
1990 | $a[$i]=~ m/(.)/g; | |
1991 | cmp_ok pos($a[$i]), '>', 0, "infinite m//g on arrays (aelem)"; | |
1992 | ||
1993 | my %h; | |
1994 | $h{a} = $^X . '-'; | |
1995 | $h{a}=~ m/(.)/g; | |
1996 | cmp_ok pos($h{a}), '>', 0, "infinite m//g on hashes (helem)"; | |
e26a4975 | 1997 | } |
0aa395f8 NC |
1998 | |
1999 | SKIP: | |
2000 | { | |
2001 | my $got_dualvar; | |
2002 | eval 'use Scalar::Util "dualvar"; $got_dualvar++'; | |
2003 | skip "No Scalar::Util::dualvar" unless $got_dualvar; | |
2004 | my $a = Scalar::Util::dualvar(3, $^X); | |
2005 | my $b = $a + 5; | |
2006 | is ($b, 8, "Arithmetic on tainted dualvars works"); | |
2007 | } | |
f27977c3 MH |
2008 | |
2009 | # opening '|-' should not trigger $ENV{PATH} check | |
2010 | ||
2011 | { | |
2012 | SKIP: { | |
2013 | skip "fork() is not available", 3 unless $Config{'d_fork'}; | |
1fb83d06 SS |
2014 | skip "opening |- is not stable on threaded Open/MirBSD with taint", 3 |
2015 | if $Config{useithreads} and $Is_OpenBSD || $Is_MirBSD; | |
f27977c3 MH |
2016 | |
2017 | $ENV{'PATH'} = $TAINT; | |
2018 | local $SIG{'PIPE'} = 'IGNORE'; | |
2019 | eval { | |
2020 | my $pid = open my $pipe, '|-'; | |
2021 | if (!defined $pid) { | |
2022 | die "open failed: $!"; | |
2023 | } | |
2024 | if (!$pid) { | |
2025 | kill 'KILL', $$; # child suicide | |
2026 | } | |
2027 | close $pipe; | |
2028 | }; | |
c3197de1 NC |
2029 | unlike($@, qr/Insecure \$ENV/, 'fork triggers %ENV check'); |
2030 | is($@, '', 'pipe/fork/open/close failed'); | |
f27977c3 MH |
2031 | eval { |
2032 | open my $pipe, "|$Invoke_Perl -e 1"; | |
2033 | close $pipe; | |
2034 | }; | |
c3197de1 | 2035 | like($@, qr/Insecure \$ENV/, 'popen neglects %ENV check'); |
f27977c3 MH |
2036 | } |
2037 | } | |
5d121f7f RD |
2038 | |
2039 | { | |
2040 | package AUTOLOAD_TAINT; | |
2041 | sub AUTOLOAD { | |
2042 | our $AUTOLOAD; | |
2043 | return if $AUTOLOAD =~ /DESTROY/; | |
2044 | if ($AUTOLOAD =~ /untainted/) { | |
f37ea7f0 | 2045 | main::isnt_tainted($AUTOLOAD, '$AUTOLOAD can be untainted'); |
d40bf27b | 2046 | my $copy = $AUTOLOAD; |
f37ea7f0 | 2047 | main::isnt_tainted($copy, '$AUTOLOAD can be untainted'); |
5d121f7f | 2048 | } else { |
f37ea7f0 | 2049 | main::is_tainted($AUTOLOAD, '$AUTOLOAD can be tainted'); |
d40bf27b | 2050 | my $copy = $AUTOLOAD; |
f37ea7f0 | 2051 | main::is_tainted($copy, '$AUTOLOAD can be tainted'); |
5d121f7f RD |
2052 | } |
2053 | } | |
2054 | ||
2055 | package main; | |
2056 | my $o = bless [], 'AUTOLOAD_TAINT'; | |
d40bf27b | 2057 | $o->untainted; |
5d121f7f RD |
2058 | $o->$TAINT; |
2059 | $o->untainted; | |
2060 | } | |
2061 | ||
20ee07fb RGS |
2062 | { |
2063 | # tests for tainted format in s?printf | |
e06d98fb DM |
2064 | my $fmt = $TAINT . "# %s\n"; |
2065 | violates_taint(sub { printf($fmt, "foo") }, 'printf', | |
4e74b85b | 2066 | q/printf doesn't like tainted formats/); |
e06d98fb DM |
2067 | violates_taint(sub { printf($TAINT . "# %s\n", "foo") }, 'printf', |
2068 | q/printf doesn't like tainted format expressions/); | |
20ee07fb | 2069 | eval { printf("# %s\n", $TAINT . "foo") }; |
433f4d03 | 2070 | is($@, '', q/printf accepts other tainted args/); |
e06d98fb | 2071 | violates_taint(sub { sprintf($fmt, "foo") }, 'sprintf', |
4e74b85b | 2072 | q/sprintf doesn't like tainted formats/); |
e06d98fb DM |
2073 | violates_taint(sub { sprintf($TAINT . "# %s\n", "foo") }, 'sprintf', |
2074 | q/sprintf doesn't like tainted format expressions/); | |
20ee07fb | 2075 | eval { sprintf("# %s\n", $TAINT . "foo") }; |
433f4d03 | 2076 | is($@, '', q/sprintf accepts other tainted args/); |
20ee07fb | 2077 | } |
085bde85 NC |
2078 | |
2079 | { | |
2080 | # 40708 | |
2081 | my $n = 7e9; | |
2082 | 8e9 - $n; | |
2083 | ||
2084 | my $val = $n; | |
2085 | is ($val, '7000000000', 'Assignment to untainted variable'); | |
2086 | $val = $TAINT; | |
2087 | $val = $n; | |
2088 | is ($val, '7000000000', 'Assignment to tainted variable'); | |
2089 | } | |
5e500fc8 NC |
2090 | |
2091 | { | |
5e500fc8 NC |
2092 | my $val = 0; |
2093 | my $tainted = '1' . $TAINT; | |
2094 | eval '$val = eval $tainted;'; | |
2095 | is ($val, 0, "eval doesn't like tainted strings"); | |
2096 | like ($@, qr/^Insecure dependency in eval/); | |
2097 | ||
abb7fb96 | 2098 | # Rather nice code to get a tainted undef by from Rick Delaney |
22d7dfed NC |
2099 | open my $fh, "test.pl" or die $!; |
2100 | seek $fh, 0, 2 or die $!; | |
2101 | $tainted = <$fh>; | |
5e500fc8 NC |
2102 | |
2103 | eval 'eval $tainted'; | |
2104 | like ($@, qr/^Insecure dependency in eval/); | |
2105 | } | |
beeaa6fd | 2106 | |
d3706118 NC |
2107 | foreach my $ord (78, 163, 256) { |
2108 | # 47195 | |
2109 | my $line = 'A1' . $TAINT . chr $ord; | |
2110 | chop $line; | |
2111 | is($line, 'A1'); | |
2112 | $line =~ /(A\S*)/; | |
f37ea7f0 | 2113 | isnt_tainted($1, "\\S match with chr $ord"); |
d3706118 NC |
2114 | } |
2115 | ||
ec93b65f | 2116 | { |
7139292d JR |
2117 | SKIP: { |
2118 | skip 'No crypt function, skipping crypt tests', 4 if(!$Config{d_crypt}); | |
2119 | # 59998 | |
a2d725a2 P |
2120 | sub cr { |
2121 | # On platforms implementing FIPS mode, using a weak algorithm | |
2122 | # (including the default triple-DES algorithm) causes crypt(3) to | |
2123 | # return a null pointer, which Perl converts into undef. We assume | |
2124 | # for now that all such platforms support glibc-style selection of | |
2125 | # a different hashing algorithm. | |
e7a4a717 | 2126 | # glibc supports MD5, but OpenBSD only supports Blowfish. |
a2d725a2 | 2127 | my $alg = ''; # Use default algorithm |
e7a4a717 AD |
2128 | if ( !defined(crypt("ab", $alg."cd")) ) { |
2129 | $alg = '$5$'; # Try SHA-256 | |
2130 | } | |
2131 | if ( !defined(crypt("ab", $alg."cd")) ) { | |
2132 | $alg = '$2b$12$FPWWO2RJ3CK4FINTw0Hi'; # Try Blowfish | |
2133 | } | |
2134 | if ( !defined(crypt("ab", $alg."cd")) ) { | |
2135 | $alg = ''; # Nothing worked. Back to default | |
a2d725a2 P |
2136 | } |
2137 | my $x = crypt($_[0], $alg . $_[1]); | |
2138 | $x | |
2139 | } | |
7139292d JR |
2140 | sub co { my $x = ~$_[0]; $x } |
2141 | my ($a, $b); | |
2142 | $a = cr('hello', 'foo' . $TAINT); | |
2143 | $b = cr('hello', 'foo'); | |
2144 | is_tainted($a, "tainted crypt"); | |
2145 | isnt_tainted($b, "untainted crypt"); | |
2146 | $a = co('foo' . $TAINT); | |
2147 | $b = co('foo'); | |
2148 | is_tainted($a, "tainted complement"); | |
2149 | isnt_tainted($b, "untainted complement"); | |
2150 | } | |
ec93b65f CS |
2151 | } |
2152 | ||
302c0c93 NC |
2153 | { |
2154 | my @data = qw(bonk zam zlonk qunckkk); | |
2155 | # Clearly some sort of usenet bang-path | |
2156 | my $string = $TAINT . join "!", @data; | |
2157 | ||
f37ea7f0 | 2158 | is_tainted($string, "tainted data"); |
302c0c93 NC |
2159 | |
2160 | my @got = split /!|,/, $string; | |
2161 | ||
2162 | # each @got would be useful here, but I want the test for earlier perls | |
2163 | for my $i (0 .. $#data) { | |
f37ea7f0 | 2164 | is_tainted($got[$i], "tainted result $i"); |
302c0c93 NC |
2165 | is($got[$i], $data[$i], "correct content $i"); |
2166 | } | |
2167 | ||
f37ea7f0 | 2168 | is_tainted($string, "still tainted data"); |
302c0c93 NC |
2169 | |
2170 | my @got = split /[!,]/, $string; | |
2171 | ||
2172 | # each @got would be useful here, but I want the test for earlier perls | |
2173 | for my $i (0 .. $#data) { | |
f37ea7f0 | 2174 | is_tainted($got[$i], "tainted result $i"); |
302c0c93 NC |
2175 | is($got[$i], $data[$i], "correct content $i"); |
2176 | } | |
2177 | ||
f37ea7f0 | 2178 | is_tainted($string, "still tainted data"); |
302c0c93 NC |
2179 | |
2180 | my @got = split /!/, $string; | |
2181 | ||
2182 | # each @got would be useful here, but I want the test for earlier perls | |
2183 | for my $i (0 .. $#data) { | |
f37ea7f0 | 2184 | is_tainted($got[$i], "tainted result $i"); |
302c0c93 NC |
2185 | is($got[$i], $data[$i], "correct content $i"); |
2186 | } | |
2187 | } | |
2188 | ||
3c4fb04a RB |
2189 | # Bug RT #52552 - broken by change at git commit id f337b08 |
2190 | { | |
2191 | my $x = $TAINT. q{print "Hello world\n"}; | |
2192 | my $y = pack "a*", $x; | |
f37ea7f0 | 2193 | is_tainted($y, "pack a* preserves tainting"); |
3c4fb04a RB |
2194 | |
2195 | my $z = pack "A*", q{print "Hello world\n"}.$TAINT; | |
f37ea7f0 | 2196 | is_tainted($z, "pack A* preserves tainting"); |
3c4fb04a RB |
2197 | |
2198 | my $zz = pack "a*a*", q{print "Hello world\n"}, $TAINT; | |
f37ea7f0 | 2199 | is_tainted($zz, "pack a*a* preserves tainting"); |
3c4fb04a RB |
2200 | } |
2201 | ||
0097b436 DM |
2202 | # Bug RT #61976 tainted $! would show numeric rather than string value |
2203 | ||
2204 | { | |
2205 | my $tainted_path = substr($^X,0,0) . "/no/such/file"; | |
2206 | my $err; | |
2207 | # $! is used in a tainted expression, so gets tainted | |
2208 | open my $fh, $tainted_path or $err= "$!"; | |
2209 | unlike($err, qr/^\d+$/, 'tainted $!'); | |
2210 | } | |
2211 | ||
b112cff9 DM |
2212 | { |
2213 | # #6758: tainted values become untainted in tied hashes | |
2214 | # (also applies to other value magic such as pos) | |
2215 | ||
2216 | ||
2217 | package P6758; | |
2218 | ||
2219 | sub TIEHASH { bless {} } | |
2220 | sub TIEARRAY { bless {} } | |
2221 | ||
2222 | my $i = 0; | |
2223 | ||
2224 | sub STORE { | |
f37ea7f0 NC |
2225 | main::is_tainted($_[1], "tied arg1 tainted"); |
2226 | main::is_tainted($_[2], "tied arg2 tainted"); | |
b112cff9 DM |
2227 | $i++; |
2228 | } | |
2229 | ||
2230 | package main; | |
2231 | ||
2232 | my ($k,$v) = qw(1111 val); | |
2233 | taint_these($k,$v); | |
2234 | tie my @array, 'P6758'; | |
2235 | tie my %hash , 'P6758'; | |
2236 | $array[$k] = $v; | |
2237 | $hash{$k} = $v; | |
2238 | ok $i == 2, "tied STORE called correct number of times"; | |
2239 | } | |
2240 | ||
3e6bd4bf | 2241 | # Bug RT #45167 the return value of sprintf sometimes wasn't tainted |
5c25e937 | 2242 | # when the args were tainted. This only occurred on the first use of |
3e6bd4bf DM |
2243 | # sprintf; after that, its TARG has taint magic attached, so setmagic |
2244 | # at the end works. That's why there are multiple sprintf's below, rather | |
93f09d7b | 2245 | # than just one wrapped in an inner loop. Also, any plaintext between |
8ab0bcfc | 2246 | # format entries would correctly cause tainting to get set. so test with |
3e6bd4bf DM |
2247 | # "%s%s" rather than eg "%s %s". |
2248 | ||
2249 | { | |
2250 | for my $var1 ($TAINT, "123") { | |
2251 | for my $var2 ($TAINT0, "456") { | |
8e29defb NC |
2252 | is( tainted(sprintf '%s', $var1, $var2), tainted($var1), |
2253 | "sprintf '%s', '$var1', '$var2'" ); | |
2254 | is( tainted(sprintf ' %s', $var1, $var2), tainted($var1), | |
2255 | "sprintf ' %s', '$var1', '$var2'" ); | |
2256 | is( tainted(sprintf '%s%s', $var1, $var2), | |
2257 | tainted($var1) || tainted($var2), | |
2258 | "sprintf '%s%s', '$var1', '$var2'" ); | |
3e6bd4bf DM |
2259 | } |
2260 | } | |
2261 | } | |
2262 | ||
2263 | ||
447ee134 DM |
2264 | # Bug RT #67962: old tainted $1 gets treated as tainted |
2265 | # in next untainted # match | |
2266 | ||
2267 | { | |
2268 | use re 'taint'; | |
2269 | "abc".$TAINT =~ /(.*)/; # make $1 tainted | |
f37ea7f0 | 2270 | is_tainted($1, '$1 should be tainted'); |
447ee134 DM |
2271 | |
2272 | my $untainted = "abcdef"; | |
f37ea7f0 | 2273 | isnt_tainted($untainted, '$untainted should be untainted'); |
447ee134 | 2274 | $untainted =~ s/(abc)/$1/; |
f37ea7f0 | 2275 | isnt_tainted($untainted, '$untainted should still be untainted'); |
447ee134 | 2276 | $untainted =~ s/(abc)/x$1/; |
f37ea7f0 | 2277 | isnt_tainted($untainted, '$untainted should yet still be untainted'); |
447ee134 DM |
2278 | } |
2279 | ||
7e6078c6 | 2280 | { |
d4456f89 JD |
2281 | # On Windows we can't spawn a fresh Perl interpreter unless at |
2282 | # least the Windows system directory (usually C:\Windows\System32) | |
2283 | # is still on the PATH. There is however no way to determine the | |
2284 | # actual path on the current system without loading the Win32 | |
2285 | # module, so we just restore the original $ENV{PATH} here. | |
2286 | local $ENV{PATH} = $ENV{PATH}; | |
2287 | $ENV{PATH} = $old_env_path if $Is_MSWin32; | |
2288 | ||
7e6078c6 NT |
2289 | fresh_perl_is(<<'end', "ok", { switches => [ '-T' ] }, |
2290 | $TAINT = substr($^X, 0, 0); | |
00cb33d6 FC |
2291 | formline('@'.('<'x("2000".$TAINT)).' | @*', 'hallo', 'welt'); |
2292 | print "ok"; | |
7e6078c6 NT |
2293 | end |
2294 | "formline survives a tainted dynamic picture"); | |
2295 | } | |
0097b436 | 2296 | |
125b9982 | 2297 | { |
f37ea7f0 | 2298 | isnt_tainted($^A, "format accumulator not tainted yet"); |
99e6ea26 | 2299 | formline('@ | @*', 'hallo' . $TAINT, 'welt'); |
f37ea7f0 | 2300 | is_tainted($^A, "tainted formline argument makes a tainted accumulator"); |
99e6ea26 | 2301 | $^A = ""; |
f37ea7f0 | 2302 | isnt_tainted($^A, "accumulator can be explicitly untainted"); |
99e6ea26 | 2303 | formline('@' .('<'*5) . ' | @*', 'hallo', 'welt'); |
f37ea7f0 | 2304 | isnt_tainted($^A, "accumulator still untainted"); |
99e6ea26 | 2305 | $^A = "" . $TAINT; |
f37ea7f0 | 2306 | is_tainted($^A, "accumulator can be explicitly tainted"); |
99e6ea26 | 2307 | formline('@' .('<'*5) . ' | @*', 'hallo', 'welt'); |
f37ea7f0 | 2308 | is_tainted($^A, "accumulator still tainted"); |
99e6ea26 | 2309 | $^A = ""; |
f37ea7f0 | 2310 | isnt_tainted($^A, "accumulator untainted again"); |
99e6ea26 | 2311 | formline('@' .('<'*5) . ' | @*', 'hallo', 'welt'); |
f37ea7f0 | 2312 | isnt_tainted($^A, "accumulator still untainted"); |
99e6ea26 | 2313 | formline('@' .('<'*(5+$TAINT0)) . ' | @*', 'hallo', 'welt'); |
f2da823f | 2314 | is_tainted($^A, "the accumulator should be tainted already"); |
f37ea7f0 | 2315 | is_tainted($^A, "tainted formline picture makes a tainted accumulator"); |
99e6ea26 NT |
2316 | } |
2317 | ||
929fffa4 KW |
2318 | { # Bug #80610 |
2319 | "Constant(1)" =~ / ^ ([a-z_]\w*) (?: [(] (.*) [)] )? $ /xi; | |
2320 | my $a = $1; | |
2321 | my $b = $2; | |
f37ea7f0 NC |
2322 | isnt_tainted($a, "regex optimization of single char /[]/i doesn't taint"); |
2323 | isnt_tainted($b, "regex optimization of single char /[]/i doesn't taint"); | |
929fffa4 KW |
2324 | } |
2325 | ||
8985fe98 DM |
2326 | { |
2327 | # RT 81230: tainted value during FETCH created extra ref to tied obj | |
2328 | ||
2329 | package P81230; | |
2330 | use warnings; | |
2331 | ||
2332 | my %h; | |
2333 | ||
2334 | sub TIEHASH { | |
2335 | my $x = $^X; # tainted | |
2336 | bless \$x; | |
2337 | } | |
2338 | sub FETCH { my $x = $_[0]; $$x . "" } | |
2339 | ||
2340 | tie %h, 'P81230'; | |
2341 | ||
2342 | my $w = ""; | |
2343 | local $SIG{__WARN__} = sub { $w .= "@_" }; | |
2344 | ||
2345 | untie %h if $h{"k"}; | |
2346 | ||
2347 | ::is($w, "", "RT 81230"); | |
2348 | } | |
2349 | ||
5a909b52 GG |
2350 | { |
2351 | # Compiling a subroutine inside a tainted expression does not make the | |
2352 | # constant folded values tainted. | |
2353 | my $x = sub { "x" . "y" }; | |
2354 | my $y = $ENV{PATH} . $x->(); # Compile $x inside a tainted expression | |
2355 | my $z = $x->(); | |
f37ea7f0 | 2356 | isnt_tainted($z, "Constants folded value not tainted"); |
5a909b52 | 2357 | } |
8985fe98 | 2358 | |
9274aefd DM |
2359 | { |
2360 | # now that regexes are first class SVs, make sure that they themselves | |
2361 | # as well as references to them are tainted | |
2362 | ||
2363 | my $rr = qr/(.)$TAINT/; | |
2364 | my $r = $$rr; # bare REGEX | |
2365 | my $s ="abc"; | |
2366 | ok($s =~ s/$r/x/, "match bare regex"); | |
f37ea7f0 | 2367 | is_tainted($s, "match bare regex taint"); |
9274aefd DM |
2368 | is($s, 'xbc', "match bare regex taint value"); |
2369 | } | |
2370 | ||
0e9be77f DM |
2371 | { |
2372 | # [perl #82616] security Issues with user-defined \p{} properties | |
2373 | # A using a tainted user-defined property should croak | |
2374 | ||
2375 | sub IsA { sprintf "%02x", ord("A") } | |
2376 | ||
2377 | my $prop = "IsA"; | |
2378 | ok("A" =~ /\p{$prop}/, "user-defined property: non-tainted case"); | |
2379 | $prop = "IsA$TAINT"; | |
2380 | eval { "A" =~ /\p{$prop}/}; | |
92e8e650 | 2381 | like($@, qr/Insecure user-defined property \\p\{main::IsA\}/, |
0e9be77f DM |
2382 | "user-defined property: tainted case"); |
2383 | } | |
2384 | ||
539689e7 FC |
2385 | { |
2386 | # [perl #87336] lc/uc(first) failing to taint the returned string | |
2387 | my $source = "foo$TAINT"; | |
2388 | my $dest = lc $source; | |
2389 | is_tainted $dest, "lc(tainted) taints its return value"; | |
2390 | $dest = lcfirst $source; | |
2391 | is_tainted $dest, "lcfirst(tainted) taints its return value"; | |
2392 | $dest = uc $source; | |
2393 | is_tainted $dest, "uc(tainted) taints its return value"; | |
2394 | $dest = ucfirst $source; | |
2395 | is_tainted $dest, "ucfirst(tainted) taints its return value"; | |
2396 | } | |
2397 | ||
fa22d357 VP |
2398 | { |
2399 | # Taintedness of values returned from given() | |
2400 | use feature 'switch'; | |
0f539b13 | 2401 | no warnings 'experimental::smartmatch'; |
fa22d357 | 2402 | |
7896dde7 | 2403 | my @descriptions = ('when', 'given end', 'default'); |
fa22d357 VP |
2404 | |
2405 | for (qw<x y z>) { | |
2406 | my $letter = "$_$TAINT"; | |
2407 | ||
2408 | my $desc = "tainted value returned from " . shift(@descriptions); | |
2409 | ||
2410 | my $res = do { | |
2411 | given ($_) { | |
7896dde7 Z |
2412 | when ('x') { $letter } |
2413 | when ('y') { goto leavegiven } | |
2414 | default { $letter } | |
fa22d357 VP |
2415 | leavegiven: $letter |
2416 | } | |
2417 | }; | |
2418 | is $res, $letter, "$desc is correct"; | |
2419 | is_tainted $res, "$desc stays tainted"; | |
2420 | } | |
2421 | } | |
2422 | ||
0d1104b4 NT |
2423 | |
2424 | # tainted constants and index() | |
2425 | # RT 64804; http://bugs.debian.org/291450 | |
2426 | { | |
2427 | ok(tainted $old_env_path, "initial taintedness"); | |
2428 | BEGIN { no strict 'refs'; my $v = $old_env_path; *{"::C"} = sub () { $v }; } | |
2429 | ok(tainted C, "constant is tainted properly"); | |
2430 | ok(!tainted "", "tainting not broken yet"); | |
2431 | index(undef, C); | |
0d1104b4 NT |
2432 | ok(!tainted "", "tainting still works after index() of the constant"); |
2433 | } | |
2434 | ||
7896dde7 Z |
2435 | # Tainted values with smartmatch |
2436 | # [perl #93590] S_do_smartmatch stealing its own string buffers | |
2437 | { | |
2438 | no warnings 'experimental::smartmatch'; | |
2439 | ok "M$TAINT" ~~ ['m', 'M'], '$tainted ~~ ["whatever", "match"]'; | |
2440 | ok !("M$TAINT" ~~ ['m', undef]), '$tainted ~~ ["whatever", undef]'; | |
2441 | } | |
2442 | ||
5a0c33f0 FC |
2443 | # Tainted values and ref() |
2444 | for(1,2) { | |
2445 | my $x = bless \"M$TAINT", ref(bless[], "main"); | |
2446 | } | |
2447 | pass("no death when TARG of ref is tainted"); | |
2448 | ||
19db9fb7 Z |
2449 | # $$ should not be tainted by being read in a tainted expression. |
2450 | { | |
2451 | isnt_tainted $$, "PID not tainted initially"; | |
2452 | my $x = $ENV{PATH}.$$; | |
2453 | isnt_tainted $$, "PID not tainted when read in tainted expression"; | |
2454 | } | |
2455 | ||
569f7fc5 | 2456 | SKIP: { |
ef9d5242 | 2457 | skip 'Locales not available', 4 unless locales_enabled('LC_CTYPE'); |
569f7fc5 | 2458 | |
838f2281 | 2459 | use feature 'fc'; |
5f1269ab | 2460 | use locale; |
838f2281 BF |
2461 | my ($latin1, $utf8) = ("\xDF") x 2; |
2462 | utf8::downgrade($latin1); | |
2463 | utf8::upgrade($utf8); | |
2464 | ||
2465 | is_tainted fc($latin1), "under locale, lc(latin1) taints the result"; | |
2466 | is_tainted fc($utf8), "under locale, lc(utf8) taints the result"; | |
2467 | ||
2468 | is_tainted "\F$latin1", "under locale, \\Flatin1 taints the result"; | |
2469 | is_tainted "\F$utf8", "under locale, \\Futf8 taints the result"; | |
2470 | } | |
0d1104b4 | 2471 | |
af89892e | 2472 | { # 111654 |
af89892e TC |
2473 | eval { |
2474 | eval { die "Test\n".substr($ENV{PATH}, 0, 0); }; | |
2475 | die; | |
2476 | }; | |
2477 | like($@, qr/^Test\n\t\.\.\.propagated at /, "error should be propagated"); | |
2478 | } | |
2479 | ||
d24ca0c5 DM |
2480 | # tainted run-time (?{}) should die |
2481 | ||
2482 | { | |
2483 | my $code = '(?{})' . $TAINT; | |
2484 | use re 'eval'; | |
2485 | eval { "a" =~ /$code/ }; | |
2486 | like($@, qr/Eval-group in insecure regular expression/, "tainted (?{})"); | |
2487 | } | |
2488 | ||
fdfdd8f7 FC |
2489 | # reset() and tainted undef (?!) |
2490 | $::x = "foo"; | |
2491 | $_ = "$TAINT".reset "x"; | |
2492 | is eval { eval $::x.1 }, 1, 'reset does not taint undef'; | |
2493 | ||
64ff300b | 2494 | # [perl #122669] |
eaff586a FC |
2495 | { |
2496 | # See the comment above the first formline test. | |
2497 | local $ENV{PATH} = $ENV{PATH}; | |
2498 | $ENV{PATH} = $old_env_path if $Is_MSWin32; | |
2499 | is runperl( | |
2500 | switches => [ '-T' ], | |
2501 | prog => 'use constant K=>$^X; 0 if K; BEGIN{} use strict; ' | |
2502 | .'print 122669, qq-\n-', | |
2503 | stderr => 1, | |
2504 | ), "122669\n", | |
2505 | 'tainted constant as logop condition should not prevent "use"'; | |
2506 | } | |
64ff300b | 2507 | |
230ee21f DM |
2508 | # optimised SETi etc need to handle tainting |
2509 | ||
2510 | { | |
2511 | my ($i1, $i2, $i3) = (1, 1, 1); | |
2512 | my ($n1, $n2, $n3) = (1.1, 1.1, 1.1); | |
2513 | my $tn = $TAINT0 + 1.1; | |
2514 | ||
2515 | $i1 = $TAINT0 + 2; | |
2516 | is_tainted $i1, "+ SETi"; | |
2517 | $i2 = $TAINT0 - 2; | |
2518 | is_tainted $i2, "- SETi"; | |
2519 | $i3 = $TAINT0 * 2; | |
2520 | is_tainted $i3, "* SETi"; | |
2521 | ||
2522 | $n1 = $tn + 2.2; | |
2523 | is_tainted $n1, "+ SETn"; | |
2524 | $n2 = $tn - 2.2; | |
2525 | is_tainted $n2, "- SETn"; | |
2526 | $n3 = $tn * 2.2; | |
2527 | is_tainted $n3, "* SETn"; | |
2528 | } | |
2529 | ||
3c84a230 DM |
2530 | # check that localizing something with get magic (e.g. taint) doesn't |
2531 | # upgrade pIOK to IOK | |
2532 | ||
2533 | { | |
2534 | local our $x = 1.1 + $TAINT0; # $x should be NOK | |
2535 | my $ix = int($x); # now NOK, pIOK | |
2536 | { | |
2537 | local $x = 0; | |
2538 | } | |
2539 | my $x1 = $x * 1; | |
2540 | isnt($x, 1); # it should be 1.1, not 1 | |
2541 | } | |
2542 | ||
c73f612f DM |
2543 | # RT #129996 |
2544 | # every item in a list assignment is independent, even if the lvalue | |
2545 | # has taint magic already | |
2546 | { | |
2547 | my ($a, $b, $c, $d); | |
2548 | $d = ""; | |
2549 | $b = $TAINT; | |
2550 | ($a, $b, $c) = ($TAINT, 0, 0); | |
2551 | is_tainted $a, "list assign tainted a"; | |
2552 | isnt_tainted $b, "list assign tainted b"; | |
2553 | isnt_tainted $c, "list assign tainted c"; | |
2554 | ||
2555 | $b = $TAINT; | |
2556 | $b = ""; # untaint; | |
2557 | ($a, $b, $c) = ($TAINT, 0, 0); | |
2558 | is_tainted $a, "list assign detainted a"; | |
2559 | isnt_tainted $b, "list assign detainted b"; | |
2560 | isnt_tainted $c, "list assign detainted c"; | |
2561 | ||
2562 | $b = $TAINT; | |
2563 | $b = ""; # untaint; | |
2564 | ($a, $b, $c) = ($TAINT); | |
2565 | is_tainted $a, "list assign empty rhs a"; | |
2566 | isnt_tainted $b, "list assign empty rhs b"; | |
2567 | isnt_tainted $c, "list assign empty rhs c"; | |
2568 | ||
2569 | $b = $TAINT; | |
2570 | $b = ""; # untaint; | |
2571 | ($a = ($TAINT. "x")), (($b, $c) = (0)); | |
2572 | is_tainted $a, "list assign already tainted expression a"; | |
2573 | isnt_tainted $b, "list assign already tainted expression b"; | |
2574 | isnt_tainted $c, "list assign already tainted expression c"; | |
2575 | ||
2576 | $b = $TAINT; | |
2577 | $b = ""; # untaint; | |
2578 | (($a) = ($TAINT. "x")), ($b = $b . "x"); | |
2579 | is_tainted $a, "list assign post tainted expression a"; | |
2580 | isnt_tainted $b, "list assign post tainted expression b"; | |
2581 | } | |
2582 | ||
00a68463 FC |
2583 | # Module::Runtime was temporarily broken between 5.27.0 and 5.27.1 because |
2584 | # ref() would fail an assertion in a tainted statement. (No ok() neces- | |
2585 | # sary since it aborts when it fails.) | |
2586 | () = defined $^X && ref \$^X; | |
2587 | ||
c4f4b223 Z |
2588 | # taint passing through overloading |
2589 | package OvTaint { | |
2590 | sub new { bless({ t => $_[1] }, $_[0]) } | |
2591 | use overload '""' => sub { $_[0]->{t} ? "hi".$TAINT : "hello" }; | |
2592 | } | |
2593 | my $ovclean = OvTaint->new(0); | |
2594 | my $ovtaint = OvTaint->new(1); | |
2595 | isnt_tainted("$ovclean", "overload preserves cleanliness"); | |
2596 | is_tainted("$ovtaint", "overload preserves taint"); | |
2597 | ||
2598 | # substitutions with overloaded replacement | |
2599 | { | |
2600 | my ($desc, $s, $res, $one); | |
2601 | ||
2602 | $desc = "substitution with partial replacement overloaded and clean"; | |
2603 | $s = 'abcd'; | |
2604 | $res = $s =~ s/(.+)/xyz$ovclean/; | |
2605 | $one = $1; | |
2606 | isnt_tainted($s, "$desc: s not tainted"); | |
2607 | isnt_tainted($res, "$desc: res not tainted"); | |
2608 | isnt_tainted($one, "$desc: \$1 not tainted"); | |
2609 | is($s, 'xyzhello', "$desc: s value"); | |
2610 | is($res, 1, "$desc: res value"); | |
2611 | is($one, 'abcd', "$desc: \$1 value"); | |
2612 | ||
2613 | $desc = "substitution with partial replacement overloaded and tainted"; | |
2614 | $s = 'abcd'; | |
2615 | $res = $s =~ s/(.+)/xyz$ovtaint/; | |
2616 | $one = $1; | |
2617 | is_tainted($s, "$desc: s tainted"); | |
2618 | isnt_tainted($res, "$desc: res not tainted"); | |
2619 | isnt_tainted($one, "$desc: \$1 not tainted"); | |
2620 | is($s, 'xyzhi', "$desc: s value"); | |
2621 | is($res, 1, "$desc: res value"); | |
2622 | is($one, 'abcd', "$desc: \$1 value"); | |
2623 | ||
2624 | $desc = "substitution with whole replacement overloaded and clean"; | |
2625 | $s = 'abcd'; | |
2626 | $res = $s =~ s/(.+)/$ovclean/; | |
2627 | $one = $1; | |
2628 | isnt_tainted($s, "$desc: s not tainted"); | |
2629 | isnt_tainted($res, "$desc: res not tainted"); | |
2630 | isnt_tainted($one, "$desc: \$1 not tainted"); | |
2631 | is($s, 'hello', "$desc: s value"); | |
2632 | is($res, 1, "$desc: res value"); | |
2633 | is($one, 'abcd', "$desc: \$1 value"); | |
2634 | ||
2635 | $desc = "substitution with whole replacement overloaded and tainted"; | |
2636 | $s = 'abcd'; | |
2637 | $res = $s =~ s/(.+)/$ovtaint/; | |
2638 | $one = $1; | |
2639 | is_tainted($s, "$desc: s tainted"); | |
2640 | isnt_tainted($res, "$desc: res not tainted"); | |
2641 | isnt_tainted($one, "$desc: \$1 not tainted"); | |
2642 | is($s, 'hi', "$desc: s value"); | |
2643 | is($res, 1, "$desc: res value"); | |
2644 | is($one, 'abcd', "$desc: \$1 value"); | |
2645 | ||
2646 | $desc = "substitution /e with partial replacement overloaded and clean"; | |
2647 | $s = 'abcd'; | |
2648 | $res = $s =~ s/(.+)/"xyz".$ovclean/e; | |
2649 | $one = $1; | |
2650 | isnt_tainted($s, "$desc: s not tainted"); | |
2651 | isnt_tainted($res, "$desc: res not tainted"); | |
2652 | isnt_tainted($one, "$desc: \$1 not tainted"); | |
2653 | is($s, 'xyzhello', "$desc: s value"); | |
2654 | is($res, 1, "$desc: res value"); | |
2655 | is($one, 'abcd', "$desc: \$1 value"); | |
2656 | ||
2657 | $desc = "substitution /e with partial replacement overloaded and tainted"; | |
2658 | $s = 'abcd'; | |
2659 | $res = $s =~ s/(.+)/"xyz".$ovtaint/e; | |
2660 | $one = $1; | |
2661 | is_tainted($s, "$desc: s tainted"); | |
2662 | isnt_tainted($res, "$desc: res not tainted"); | |
2663 | isnt_tainted($one, "$desc: \$1 not tainted"); | |
2664 | is($s, 'xyzhi', "$desc: s value"); | |
2665 | is($res, 1, "$desc: res value"); | |
2666 | is($one, 'abcd', "$desc: \$1 value"); | |
2667 | ||
2668 | $desc = "substitution /e with whole replacement overloaded and clean"; | |
2669 | $s = 'abcd'; | |
2670 | $res = $s =~ s/(.+)/$ovclean/e; | |
2671 | $one = $1; | |
2672 | isnt_tainted($s, "$desc: s not tainted"); | |
2673 | isnt_tainted($res, "$desc: res not tainted"); | |
2674 | isnt_tainted($one, "$desc: \$1 not tainted"); | |
2675 | is($s, 'hello', "$desc: s value"); | |
2676 | is($res, 1, "$desc: res value"); | |
2677 | is($one, 'abcd', "$desc: \$1 value"); | |
2678 | ||
2679 | $desc = "substitution /e with whole replacement overloaded and tainted"; | |
2680 | $s = 'abcd'; | |
2681 | $res = $s =~ s/(.+)/$ovtaint/e; | |
2682 | $one = $1; | |
2683 | is_tainted($s, "$desc: s tainted"); | |
2684 | isnt_tainted($res, "$desc: res not tainted"); | |
2685 | isnt_tainted($one, "$desc: \$1 not tainted"); | |
2686 | is($s, 'hi', "$desc: s value"); | |
2687 | is($res, 1, "$desc: res value"); | |
2688 | is($one, 'abcd', "$desc: \$1 value"); | |
2689 | ||
2690 | $desc = "substitution /e with extra code and partial replacement overloaded and clean"; | |
2691 | $s = 'abcd'; | |
2692 | $res = $s =~ s/(.+)/(my $z++), "xyz".$ovclean/e; | |
2693 | $one = $1; | |
2694 | isnt_tainted($s, "$desc: s not tainted"); | |
2695 | isnt_tainted($res, "$desc: res not tainted"); | |
2696 | isnt_tainted($one, "$desc: \$1 not tainted"); | |
2697 | is($s, 'xyzhello', "$desc: s value"); | |
2698 | is($res, 1, "$desc: res value"); | |
2699 | is($one, 'abcd', "$desc: \$1 value"); | |
2700 | ||
2701 | $desc = "substitution /e with extra code and partial replacement overloaded and tainted"; | |
2702 | $s = 'abcd'; | |
2703 | $res = $s =~ s/(.+)/(my $z++), "xyz".$ovtaint/e; | |
2704 | $one = $1; | |
2705 | is_tainted($s, "$desc: s tainted"); | |
2706 | isnt_tainted($res, "$desc: res not tainted"); | |
2707 | isnt_tainted($one, "$desc: \$1 not tainted"); | |
2708 | is($s, 'xyzhi', "$desc: s value"); | |
2709 | is($res, 1, "$desc: res value"); | |
2710 | is($one, 'abcd', "$desc: \$1 value"); | |
2711 | ||
2712 | $desc = "substitution /e with extra code and whole replacement overloaded and clean"; | |
2713 | $s = 'abcd'; | |
2714 | $res = $s =~ s/(.+)/(my $z++), $ovclean/e; | |
2715 | $one = $1; | |
2716 | isnt_tainted($s, "$desc: s not tainted"); | |
2717 | isnt_tainted($res, "$desc: res not tainted"); | |
2718 | isnt_tainted($one, "$desc: \$1 not tainted"); | |
2719 | is($s, 'hello', "$desc: s value"); | |
2720 | is($res, 1, "$desc: res value"); | |
2721 | is($one, 'abcd', "$desc: \$1 value"); | |
2722 | ||
2723 | $desc = "substitution /e with extra code and whole replacement overloaded and tainted"; | |
2724 | $s = 'abcd'; | |
2725 | $res = $s =~ s/(.+)/(my $z++), $ovtaint/e; | |
2726 | $one = $1; | |
2727 | is_tainted($s, "$desc: s tainted"); | |
2728 | isnt_tainted($res, "$desc: res not tainted"); | |
2729 | isnt_tainted($one, "$desc: \$1 not tainted"); | |
2730 | is($s, 'hi', "$desc: s value"); | |
2731 | is($res, 1, "$desc: res value"); | |
2732 | is($one, 'abcd', "$desc: \$1 value"); | |
2733 | ||
2734 | $desc = "substitution /r with partial replacement overloaded and clean"; | |
2735 | $s = 'abcd'; | |
2736 | $res = $s =~ s/(.+)/xyz$ovclean/r; | |
2737 | $one = $1; | |
2738 | isnt_tainted($s, "$desc: s not tainted"); | |
2739 | isnt_tainted($res, "$desc: res not tainted"); | |
2740 | isnt_tainted($one, "$desc: \$1 not tainted"); | |
2741 | is($s, 'abcd', "$desc: s value"); | |
2742 | is($res, 'xyzhello', "$desc: res value"); | |
2743 | is($one, 'abcd', "$desc: \$1 value"); | |
2744 | ||
2745 | $desc = "substitution /r with partial replacement overloaded and tainted"; | |
2746 | $s = 'abcd'; | |
2747 | $res = $s =~ s/(.+)/xyz$ovtaint/r; | |
2748 | $one = $1; | |
2749 | isnt_tainted($s, "$desc: s not tainted"); | |
2750 | is_tainted($res, "$desc: res tainted"); | |
2751 | isnt_tainted($one, "$desc: \$1 not tainted"); | |
2752 | is($s, 'abcd', "$desc: s value"); | |
2753 | is($res, 'xyzhi', "$desc: res value"); | |
2754 | is($one, 'abcd', "$desc: \$1 value"); | |
2755 | ||
2756 | $desc = "substitution /r with whole replacement overloaded and clean"; | |
2757 | $s = 'abcd'; | |
2758 | $res = $s =~ s/(.+)/$ovclean/r; | |
2759 | $one = $1; | |
2760 | isnt_tainted($s, "$desc: s not tainted"); | |
2761 | isnt_tainted($res, "$desc: res not tainted"); | |
2762 | isnt_tainted($one, "$desc: \$1 not tainted"); | |
2763 | is($s, 'abcd', "$desc: s value"); | |
2764 | is($res, 'hello', "$desc: res value"); | |
2765 | is($one, 'abcd', "$desc: \$1 value"); | |
2766 | ||
2767 | $desc = "substitution /r with whole replacement overloaded and tainted"; | |
2768 | $s = 'abcd'; | |
2769 | $res = $s =~ s/(.+)/$ovtaint/r; | |
2770 | $one = $1; | |
2771 | isnt_tainted($s, "$desc: s not tainted"); | |
2772 | is_tainted($res, "$desc: res tainted"); | |
2773 | isnt_tainted($one, "$desc: \$1 not tainted"); | |
2774 | is($s, 'abcd', "$desc: s value"); | |
2775 | is($res, 'hi', "$desc: res value"); | |
2776 | is($one, 'abcd', "$desc: \$1 value"); | |
2777 | ||
2778 | $desc = "substitution /g with partial replacement overloaded and clean"; | |
2779 | $s = 'abcd'; | |
2780 | $res = $s =~ s/(.)/x$ovclean/g; | |
2781 | $one = $1; | |
2782 | isnt_tainted($s, "$desc: s not tainted"); | |
2783 | isnt_tainted($res, "$desc: res not tainted"); | |
2784 | isnt_tainted($one, "$desc: \$1 not tainted"); | |
2785 | is($s, 'xhello' x 4, "$desc: s value"); | |
2786 | is($res, 4, "$desc: res value"); | |
2787 | is($one, 'd', "$desc: \$1 value"); | |
2788 | ||
2789 | $desc = "substitution /g with partial replacement overloaded and tainted"; | |
2790 | $s = 'abcd'; | |
2791 | $res = $s =~ s/(.)/x$ovtaint/g; | |
2792 | $one = $1; | |
2793 | is_tainted($s, "$desc: s tainted"); | |
2794 | isnt_tainted($res, "$desc: res not tainted"); | |
2795 | isnt_tainted($one, "$desc: \$1 not tainted"); | |
2796 | is($s, 'xhi' x 4, "$desc: s value"); | |
2797 | is($res, 4, "$desc: res value"); | |
2798 | is($one, 'd', "$desc: \$1 value"); | |
2799 | ||
2800 | $desc = "substitution /g with whole replacement overloaded and clean"; | |
2801 | $s = 'abcd'; | |
2802 | $res = $s =~ s/(.)/$ovclean/g; | |
2803 | $one = $1; | |
2804 | isnt_tainted($s, "$desc: s not tainted"); | |
2805 | isnt_tainted($res, "$desc: res not tainted"); | |
2806 | isnt_tainted($one, "$desc: \$1 not tainted"); | |
2807 | is($s, 'hello' x 4, "$desc: s value"); | |
2808 | is($res, 4, "$desc: res value"); | |
2809 | is($one, 'd', "$desc: \$1 value"); | |
2810 | ||
2811 | $desc = "substitution /g with whole replacement overloaded and tainted"; | |
2812 | $s = 'abcd'; | |
2813 | $res = $s =~ s/(.)/$ovtaint/g; | |
2814 | $one = $1; | |
2815 | is_tainted($s, "$desc: s tainted"); | |
2816 | isnt_tainted($res, "$desc: res not tainted"); | |
2817 | isnt_tainted($one, "$desc: \$1 not tainted"); | |
2818 | is($s, 'hi' x 4, "$desc: s value"); | |
2819 | is($res, 4, "$desc: res value"); | |
2820 | is($one, 'd', "$desc: \$1 value"); | |
2821 | ||
2822 | $desc = "substitution /ge with partial replacement overloaded and clean"; | |
2823 | $s = 'abcd'; | |
2824 | $res = $s =~ s/(.)/"x".$ovclean/ge; | |
2825 | $one = $1; | |
2826 | isnt_tainted($s, "$desc: s not tainted"); | |
2827 | isnt_tainted($res, "$desc: res not tainted"); | |
2828 | isnt_tainted($one, "$desc: \$1 not tainted"); | |
2829 | is($s, 'xhello' x 4, "$desc: s value"); | |
2830 | is($res, 4, "$desc: res value"); | |
2831 | is($one, 'd', "$desc: \$1 value"); | |
2832 | ||
2833 | $desc = "substitution /ge with partial replacement overloaded and tainted"; | |
2834 | $s = 'abcd'; | |
2835 | $res = $s =~ s/(.)/"x".$ovtaint/ge; | |
2836 | $one = $1; | |
2837 | is_tainted($s, "$desc: s tainted"); | |
2838 | isnt_tainted($res, "$desc: res not tainted"); | |
2839 | isnt_tainted($one, "$desc: \$1 not tainted"); | |
2840 | is($s, 'xhi' x 4, "$desc: s value"); | |
2841 | is($res, 4, "$desc: res value"); | |
2842 | is($one, 'd', "$desc: \$1 value"); | |
2843 | ||
2844 | $desc = "substitution /ge with whole replacement overloaded and clean"; | |
2845 | $s = 'abcd'; | |
2846 | $res = $s =~ s/(.)/$ovclean/ge; | |
2847 | $one = $1; | |
2848 | isnt_tainted($s, "$desc: s not tainted"); | |
2849 | isnt_tainted($res, "$desc: res not tainted"); | |
2850 | isnt_tainted($one, "$desc: \$1 not tainted"); | |
2851 | is($s, 'hello' x 4, "$desc: s value"); | |
2852 | is($res, 4, "$desc: res value"); | |
2853 | is($one, 'd', "$desc: \$1 value"); | |
2854 | ||
2855 | $desc = "substitution /ge with whole replacement overloaded and tainted"; | |
2856 | $s = 'abcd'; | |
2857 | $res = $s =~ s/(.)/$ovtaint/ge; | |
2858 | $one = $1; | |
2859 | is_tainted($s, "$desc: s tainted"); | |
2860 | isnt_tainted($res, "$desc: res not tainted"); | |
2861 | isnt_tainted($one, "$desc: \$1 not tainted"); | |
2862 | is($s, 'hi' x 4, "$desc: s value"); | |
2863 | is($res, 4, "$desc: res value"); | |
2864 | is($one, 'd', "$desc: \$1 value"); | |
2865 | } | |
230ee21f | 2866 | |
5e501dc5 DM |
2867 | # RT #132385 |
2868 | # It was trying to taint a boolean return from s/// (e.g. PL_sv_yes) | |
2869 | # and was thus crashing with 'Modification of a read-only value'. | |
2870 | ||
2871 | { | |
2872 | my $s = "abcd" . $TAINT; | |
2873 | ok(!!($s =~ s/a/x/g), "RT #132385"); | |
2874 | } | |
2875 | ||
beeaa6fd NC |
2876 | # This may bomb out with the alarm signal so keep it last |
2877 | SKIP: { | |
2878 | skip "No alarm()" unless $Config{d_alarm}; | |
2879 | # Test from RT #41831] | |
2880 | # [PATCH] Bug & fix: hang when using study + taint mode (perl 5.6.1, 5.8.x) | |
2881 | ||
2882 | my $DATA = <<'END' . $TAINT; | |
2883 | line1 is here | |
2884 | line2 is here | |
2885 | line3 is here | |
2886 | line4 is here | |
2887 | ||
2888 | END | |
2889 | ||
2890 | #study $DATA; | |
2891 | ||
2892 | ## don't set $SIG{ALRM}, since we'd never get to a user-level handler as | |
2893 | ## perl is stuck in a regexp infinite loop! | |
2894 | ||
2895 | alarm(10); | |
2896 | ||
2897 | if ($DATA =~ /^line2.*line4/m) { | |
2898 | fail("Should not be a match") | |
2899 | } else { | |
2900 | pass("Match on tainted multiline data should fail promptly"); | |
2901 | } | |
2902 | ||
2903 | alarm(0); | |
2904 | } | |
2905 | __END__ | |
2906 | # Keep the previous test last |