/usr/share/perl5/DBI/Test/Case/DBD/CSV/t85_error.pm is in libdbd-csv-perl 0.4500-1.
This file is owned by root:root, with mode 0o644.
The actual contents of the file can be viewed below.
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 | package DBI::Test::Case::DBD::CSV::t85_error;
use strict;
use warnings;
use parent qw( DBI::Test::DBD::CSV::Case );
use Test::More;
use DBI::Test;
use DBI;
sub supported_variant
{
my ($self, $test_case, $cfg_pfx, $test_confs,
$dsn_pfx, $dsn_cred, $options) = @_;
$self->is_test_for_mocked ($test_confs) and return;
return $self->SUPER::supported_variant ($test_case, $cfg_pfx, $test_confs,
$dsn_pfx, $dsn_cred, $options);
} # supported_variant
my @tbl_def = (
[ "id", "INTEGER", 4, 0 ],
[ "name", "CHAR", 64, 0 ],
);
use vars q{$AUTOLOAD};
sub AUTOLOAD
{
(my $sub = $AUTOLOAD) =~ s/.*:/DBI::Test::DBD::CSV::Case::/;
{ no strict "refs";
$sub->(@_);
}
} # AUTOLOAD
sub run_test
{
my ($self, $dbc) = @_;
my @DB_CREDS = @$dbc;
$DB_CREDS[3]->{PrintError} = 0;
$DB_CREDS[3]->{RaiseError} = 0;
$DB_CREDS[3]->{f_dir} = DbDir ();
if ($ENV{DBI_PUREPERL}) {
eval "use Text::CSV;";
$@ or $DB_CREDS[3]->{csv_class} = "Text::CSV"
}
defined $ENV{DBI_SQL_NANO} or
eval "use SQL::Statement;";
my $dbh = connect_ok (@DB_CREDS, "Connect with dbi:CSV:");
ok (my $tbl = FindNewTable ($dbh), "find new test table");
like (my $def = TableDefinition ($tbl, @tbl_def),
qr{^create table $tbl}i, "table definition");
do_ok ($dbh, $def, "create table");
my $tbl_file = DbFile ($tbl);
ok (-s $tbl_file, "file exists");
ok ($dbh->disconnect, "disconnect");
undef $dbh;
ok (-f $tbl_file, "file still there");
open my $fh, ">>", $tbl_file;
print $fh qq{1, "p0wnd",",""",0\n}; # Very bad content
close $fh;
ok ($dbh = connect_ok (@DB_CREDS, "Connect with dbi:CSV:"));
{ local $dbh->{PrintError} = 0;
local $dbh->{RaiseError} = 0;
my $sth = prepare_ok ($dbh, "select * from $tbl", "prepare");
is ($sth->execute, undef, "execute should fail");
# It is safe to regex on this text, as it is NOT local dependant
like ($dbh->errstr, qr{\w+ \@ line [0-9?]+ pos [0-9?]+}, "error message");
};
do_ok ($dbh, "drop table $tbl", "drop");
ok ($dbh->disconnect, "disconnect");
done_testing ();
} # run_test
1;
|