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