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