#!perl -wT
use lib qw(blib/arch blib/lib); # needed since -T ignores PERL5LIB
use DBI qw(:sql_types);
use Config;
use Cwd;
use strict;
$^W = 1;
$| = 1;
require VMS::Filespec if $^O eq 'VMS';
use Test::More;
# Check Taint attribute works. This requires this test to be run
# manually with the -T flag: "perl -T -Mblib t/examp.t"
sub is_tainted {
my $foo;
return ! eval { ($foo=join('',@_)), kill 0; 1; };
}
sub mk_tainted {
my $string = shift;
return substr($string.$^X, 0, length($string));
}
plan skip_all => "Taint attributes not supported with DBI::PurePerl" if $DBI::PurePerl;
plan skip_all => "Taint attribute tests require taint mode (perl -T)" unless is_tainted($^X);
plan skip_all => "Taint attribute tests not functional with DBI_AUTOPROXY" if $ENV{DBI_AUTOPROXY};
plan tests => 36;
# get a dir always readable on all platforms
my $dir = getcwd() || cwd();
$dir = VMS::Filespec::unixify($dir) if $^O eq 'VMS';
$dir =~ m/(.*)/; $dir = $1 || die; # untaint $dir
my ($r, $dbh);
$dbh = DBI->connect('dbi:ExampleP:', '', '', { PrintError=>0, RaiseError=>1, Taint => 1 });
my $std_sql = "select mode,size,name from ?";
my $csr_a = $dbh->prepare($std_sql);
ok(ref $csr_a);
ok($dbh->{'Taint'});
ok($dbh->{'TaintIn'} == 1);
ok($dbh->{'TaintOut'} == 1);
$dbh->{'TaintOut'} = 0;
ok($dbh->{'Taint'} == 0);
ok($dbh->{'TaintIn'} == 1);
ok($dbh->{'TaintOut'} == 0);
$dbh->{'Taint'} = 0;
ok($dbh->{'Taint'} == 0);
ok($dbh->{'TaintIn'} == 0);
ok($dbh->{'TaintOut'} == 0);
$dbh->{'TaintIn'} = 1;
ok($dbh->{'Taint'} == 0);
ok($dbh->{'TaintIn'} == 1);
ok($dbh->{'TaintOut'} == 0);
$dbh->{'TaintOut'} = 1;
ok($dbh->{'Taint'} == 1);
ok($dbh->{'TaintIn'} == 1);
ok($dbh->{'TaintOut'} == 1);
$dbh->{'Taint'} = 0;
my $st;
eval { $st = $dbh->prepare($std_sql); };
ok(ref $st);
ok($st->{'Taint'} == 0);
ok($st->execute( $dir ), 'should execute ok');
my @row = $st->fetchrow_array;
ok(@row);
ok(!is_tainted($row[0]));
ok(!is_tainted($row[1]));
ok(!is_tainted($row[2]));
print "TaintIn\n";
$st->{'TaintIn'} = 1;
@row = $st->fetchrow_array;
ok(@row);
ok(!is_tainted($row[0]));
ok(!is_tainted($row[1]));
ok(!is_tainted($row[2]));
print "TaintOut\n";
$st->{'TaintOut'} = 1;
@row = $st->fetchrow_array;
ok(@row);
ok(is_tainted($row[0]));
ok(is_tainted($row[1]));
ok(is_tainted($row[2]));
$st->finish;
my $tainted_sql = mk_tainted($std_sql);
my $tainted_dot = mk_tainted('.');
$dbh->{'Taint'} = $csr_a->{'Taint'} = 1;
eval { $dbh->prepare($tainted_sql); 1; };
ok($@ =~ /Insecure dependency/, $@);
eval { $csr_a->execute($tainted_dot); 1; };
ok($@ =~ /Insecure dependency/, $@);
undef $@;
$dbh->{'TaintIn'} = $csr_a->{'TaintIn'} = 0;
eval { $dbh->prepare($tainted_sql); 1; };
ok(!$@, $@);
eval { $csr_a->execute($tainted_dot); 1; };
ok(!$@, $@);
$csr_a->{Taint} = 0;
ok($csr_a->{Taint} == 0);
$csr_a->finish;
$dbh->disconnect;
1;