From 0c5dbbf467da41eff179bd5d0a335555564ad11a Mon Sep 17 00:00:00 2001 From: Vernon Lyon Date: Tue, 29 Sep 2009 17:15:59 +0000 Subject: [PATCH] Fixed $sth->primary_key_info according to DBI spec --- Changes | 2 ++ lib/DBD/SQLite.pm | 9 +++-- t/27_metadata.t | 83 +++++++++++++++++++++++------------------------ 3 files changed, 50 insertions(+), 44 deletions(-) diff --git a/Changes b/Changes index 4c5de2b..647771e 100644 --- a/Changes +++ b/Changes @@ -13,6 +13,8 @@ Changes for Perl extension DBD-SQLite the spec in DBI and added support for attached databases. (VLYON) - Added documentation and an 'Escape' attribute for $sth->table_info. (VLYON) + - Fixed $sth->primary_key_info to work according to the spec in DBI + and changed the tests in t/27_metadata.t to reflect this. (VLYON) 1.26_03 Wed 12 Aug 2009 - Updated to SQLite 3.6.17 (ISHIGAKI) diff --git a/lib/DBD/SQLite.pm b/lib/DBD/SQLite.pm index e0ad1a8..62b1dff 100644 --- a/lib/DBD/SQLite.pm +++ b/lib/DBD/SQLite.pm @@ -318,12 +318,17 @@ END_SQL } sub primary_key_info { - my($dbh, $catalog, $schema, $table) = @_; + my ($dbh, $catalog, $schema, $table) = @_; + + # Escape the schema and table name + $schema =~ s/([\\_%])/\\$1/g if defined $schema; + my $escaped = $table; + $escaped =~ s/([\\_%])/\\$1/g; + my $sth_tables = $dbh->table_info($catalog, $schema, $escaped, undef, {Escape => '\\'}); # This is a hack but much simpler than using pragma index_list etc # also the pragma doesn't list 'INTEGER PRIMARY KEY' autoinc PKs! my @pk_info; - my $sth_tables = $dbh->table_info($catalog, $schema, $table, undef); while ( my $row = $sth_tables->fetchrow_hashref ) { my $sql = $row->{sqlite_sql} or next; next unless $sql =~ /(.*?)\s*PRIMARY\s+KEY\s*(?:\(\s*(.*?)\s*\))?/si; diff --git a/t/27_metadata.t b/t/27_metadata.t index 3184b0a..0919e5c 100644 --- a/t/27_metadata.t +++ b/t/27_metadata.t @@ -6,55 +6,54 @@ BEGIN { $^W = 1; } -use Test::More tests => 27; +use Test::More tests => 21; use t::lib::Test; -my $dbh = DBI->connect("dbi:SQLite:dbname=foo", "", "", { }); -ok($dbh); -$dbh->{PrintError} = 0; -$dbh->do("drop table meta$_") for 1..5; -$dbh->{PrintError} = 1; -ok $dbh->do("create table meta1 (f1 varchar(2) PRIMARY KEY, f2 char(1))"); -ok $dbh->do("create table meta2 (f1 varchar(2), f2 char(1), PRIMARY KEY (f1))"); -ok $dbh->do("create table meta3 (f2 char(1), f1 varchar(2) PRIMARY KEY)"); +# 1-4. Connect & create tables +my $dbh = connect_ok(dbfile => 'foo'); +ok $dbh->do('CREATE TABLE meta1 (f1 INTEGER PRIMARY KEY, f2 CHAR(1))'), 'Create table meta1'; +ok $dbh->do('CREATE TABLE meta2 (f1 VARCHAR(2), f2 CHAR(1), PRIMARY KEY (f1))'), 'Create table meta2'; +ok $dbh->do('CREATE TABLE meta3 (f2 CHAR(1), f1 VARCHAR(2) PRIMARY KEY)'), 'Create table meta3'; + $dbh->trace(0); $DBI::neat_maxlen = 4000; -my $sth = $dbh->primary_key_info(undef, undef, '%'); -ok $sth; -my $pki = $sth->fetchall_hashref('TABLE_NAME'); -ok $pki; + +# 5-10. Get & check primary_key_info +for my $table (qw(meta1 meta2 meta3)) { + ok my $sth = $dbh->primary_key_info(undef, undef, $table), "Get primary_key_info for $table"; + my $pki = $sth->fetchall_arrayref([3,4]); + #use Data::Dumper; print Dumper($pki); + is_deeply $pki, [['f1', 1]], "Correct primary_key_info returned for $table"; +} + +# 11-14. Multi column primary key +ok $dbh->do('CREATE TABLE meta4 (f1 VARCHAR(2), f2 CHAR(1), PRIMARY KEY (f1,f2))'), 'Create table meta4'; +ok my $sth = $dbh->primary_key_info(undef, undef, 'meta4'), 'Get primary_key_info for meta4'; +my $pki = $sth->fetchall_arrayref({COLUMN_NAME => 1, KEY_SEQ => 1}); #use Data::Dumper; print Dumper($pki); -ok keys %$pki == 3; -ok $_->{COLUMN_NAME} eq 'f1' for values %$pki; +is @$pki, 2, 'Primary key contains 2 columns'; +is_deeply $pki, [{COLUMN_NAME => 'f1', KEY_SEQ => 1},{COLUMN_NAME => 'f2', KEY_SEQ => 2}], + 'Correct primary_key_info returned for meta4'; -ok $dbh->do("create table meta4 (f1 varchar(2), f2 char(1), PRIMARY KEY (f1,f2))"); -$sth = $dbh->primary_key_info(undef, undef, 'meta4'); -ok $sth; -$pki = $sth->fetchall_hashref('COLUMN_NAME'); -ok $pki; -#use Data::Dumper; print Dumper($pki); -ok keys %$pki == 2; -ok $pki->{f1}->{KEY_SEQ} == 1; -ok $pki->{f2}->{KEY_SEQ} == 2; +# 15,16. Test primary_key +ok my @pk = $dbh->primary_key(undef, undef, 'meta4'), 'Get primary_key for meta4'; +is_deeply \@pk, [qw(f1 f2)], 'Correct primary_key returned for meta4'; -my @pk = $dbh->primary_key(undef, undef, 'meta4'); -ok @pk == 2; -ok "@pk" eq "f1 f2"; - -ok $dbh->do("insert into meta4 values ('xyz', 'b')"); -$sth = $dbh->prepare("select * from meta4"); -ok $sth; -ok $sth->execute(); -ok $sth->fetch(); +# 17-21. I'm not sure what this is testing +$dbh->do("INSERT INTO meta4 VALUES ('xyz', 'b')"); +$sth = $dbh->prepare('SELECT * FROM meta4'); +$sth->execute; +$sth->fetch; my $types = $sth->{TYPE}; my $names = $sth->{NAME}; -# warn("Types: @$types, Names: @$names\n"); -ok( @$types == @$names ); -print "# Types: @$types\n"; -print "# Names: @$names\n"; -ok($types->[0] eq 'varchar(2)'); -ok($types->[1] eq 'char(1)'); +diag "Types: @$types\nNames: @$names"; +is scalar @$types, scalar @$names, '$sth->{TYPE} array is same length as $sth->{NAME} array'; +# FIXME: This is wrong! $sth->{TYPE} should return an array of integers see: rt #46873 +TODO: { + local $TODO = '$sth->{TYPE} should return an array of integers.'; + isnt $types->[0], 'VARCHAR(2)', '$sth->{TYPE}[0] doesn\'t return a string'; + isnt $types->[1], 'CHAR(1)', '$sth->{TYPE}[1] doesn\'t return a string'; + like $types->[0], qr/^-?\d+$/, '$sth->{TYPE}[0] returns an integer'; + like $types->[1], qr/^-?\d+$/, '$sth->{TYPE}[1] returns an integer'; +} -ok $dbh->do("create table meta5 ( f1 integer PRIMARY KEY )"); -@pk = $dbh->primary_key(undef, undef, 'meta5'); -ok($pk[0] eq 'f1');