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