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