Fixed $sth->primary_key_info according to DBI spec

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)

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;

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", "", "", { });
+# 1-4. Connect & create tables
-ok($dbh);
+my $dbh = connect_ok(dbfile => 'foo');
-$dbh->{PrintError} = 0;
+ok $dbh->do('CREATE TABLE meta1 (f1 INTEGER PRIMARY KEY, f2 CHAR(1))'), 'Create table meta1';
-$dbh->do("drop table meta$_") for 1..5;
+ok $dbh->do('CREATE TABLE meta2 (f1 VARCHAR(2), f2 CHAR(1), PRIMARY KEY (f1))'), 'Create table meta2';
-$dbh->{PrintError} = 1;
+ok $dbh->do('CREATE TABLE meta3 (f2 CHAR(1), f1 VARCHAR(2) PRIMARY KEY)'), 'Create table meta3';
-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)");
 $dbh->trace(0);
 $DBI::neat_maxlen = 4000;
-my $sth = $dbh->primary_key_info(undef, undef, '%');
+
-ok $sth;
+# 5-10. Get & check primary_key_info
-my $pki = $sth->fetchall_hashref('TABLE_NAME');
+for my $table (qw(meta1 meta2 meta3)) {
-ok $pki;
+    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;
+is @$pki, 2, 'Primary key contains 2 columns';
-ok $_->{COLUMN_NAME} eq 'f1' for values %$pki;
+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))");
+# 15,16. Test primary_key
-$sth = $dbh->primary_key_info(undef, undef, 'meta4');
+ok my @pk = $dbh->primary_key(undef, undef, 'meta4'), 'Get primary_key for meta4';
-ok $sth;
+is_deeply \@pk, [qw(f1 f2)], 'Correct primary_key returned for meta4';
-$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;
 
-my @pk = $dbh->primary_key(undef, undef, 'meta4');
+# 17-21. I'm not sure what this is testing
-ok @pk == 2;
+$dbh->do("INSERT INTO meta4 VALUES ('xyz', 'b')");
-ok "@pk" eq "f1 f2";
+$sth = $dbh->prepare('SELECT * FROM meta4');
-
+$sth->execute;
-ok $dbh->do("insert into meta4 values ('xyz', 'b')");
+$sth->fetch;
-$sth = $dbh->prepare("select * from meta4");
-ok $sth;
-ok $sth->execute();
-ok $sth->fetch();
 my $types = $sth->{TYPE};
 my $names = $sth->{NAME};
-# warn("Types: @$types, Names: @$names\n");
+diag "Types: @$types\nNames: @$names";
-ok( @$types == @$names );
+is scalar @$types, scalar @$names, '$sth->{TYPE} array is same length as $sth->{NAME} array';
-print "# Types: @$types\n";
+# FIXME: This is wrong! $sth->{TYPE} should return an array of integers see: rt #46873
-print "# Names: @$names\n";
+TODO: {
-ok($types->[0] eq 'varchar(2)');
+    local $TODO = '$sth->{TYPE} should return an array of integers.';
-ok($types->[1] eq 'char(1)');
+    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');