From 2c8c79b2f4f56d5413a559498a9ce595a46f350a Mon Sep 17 00:00:00 2001 From: Laurent Dami Date: Sun, 5 Aug 2012 08:27:16 +0000 Subject: [PATCH] support for foreign_key_info --- Changes | 2 + lib/DBD/SQLite.pm | 190 +++++++++++++++++++++++++++++++++++++++- t/50_foreign_key_info.t | 119 +++++++++++++++++++++++++ 3 files changed, 310 insertions(+), 1 deletion(-) create mode 100755 t/50_foreign_key_info.t diff --git a/Changes b/Changes index 1045417..ecabc15 100644 --- a/Changes +++ b/Changes @@ -1,5 +1,7 @@ Changes for Perl extension DBD-SQLite + - added support for foreign_key_info (DAMI) + 1.38_01 to be released - Updated to SQLite 3.17.13 (ISHIGAKI) diff --git a/lib/DBD/SQLite.pm b/lib/DBD/SQLite.pm index 90142c9..3752eeb 100644 --- a/lib/DBD/SQLite.pm +++ b/lib/DBD/SQLite.pm @@ -29,6 +29,7 @@ __PACKAGE__->bootstrap($VERSION); # New or old API? use constant NEWAPI => ($DBI::VERSION >= 1.608); +# global registry of collation functions, initialized with 2 builtins tie %COLLATION, 'DBD::SQLite::_WriteOnceHash'; $COLLATION{perl} = sub { $_[0] cmp $_[1] }; $COLLATION{perllocale} = sub { use locale; $_[0] cmp $_[1] }; @@ -38,7 +39,7 @@ my $methods_are_installed = 0; sub driver { return $drh if $drh; - if (!$methods_are_installed && $DBI::VERSION >= 1.608) { + if (!$methods_are_installed && DBD::SQLite::NEWAPI ) { DBI->setup_driver('DBD::SQLite'); DBD::SQLite::db->install_method('sqlite_last_insert_rowid'); @@ -417,6 +418,120 @@ sub primary_key_info { return $sth; } + +our %DBI_code_for_rule = ( # from DBI doc; curiously, they are not exported + # by the DBI module. + # codes for update/delete constraints + 'CASCADE' => 0, + 'RESTRICT' => 1, + 'SET NULL' => 2, + 'NO ACTION' => 3, + 'SET DEFAULT' => 4, + + # codes for deferrability + 'INITIALLY DEFERRED' => 5, + 'INITIALLY IMMEDIATE' => 6, + 'NOT DEFERRABLE' => 7, + ); + + +my @FOREIGN_KEY_INFO_ODBC = ( + 'PKTABLE_CAT', # The primary (unique) key table catalog identifier. + 'PKTABLE_SCHEM', # The primary (unique) key table schema identifier. + 'PKTABLE_NAME', # The primary (unique) key table identifier. + 'PKCOLUMN_NAME', # The primary (unique) key column identifier. + 'FKTABLE_CAT', # The foreign key table catalog identifier. + 'FKTABLE_SCHEM', # The foreign key table schema identifier. + 'FKTABLE_NAME', # The foreign key table identifier. + 'FKCOLUMN_NAME', # The foreign key column identifier. + 'KEY_SEQ', # The column sequence number (starting with 1). + 'UPDATE_RULE', # The referential action for the UPDATE rule. + 'DELETE_RULE', # The referential action for the DELETE rule. + 'FK_NAME', # The foreign key name. + 'PK_NAME', # The primary (unique) key name. + 'DEFERRABILITY', # The deferrability of the foreign key constraint. + 'UNIQUE_OR_PRIMARY', # qualifies the key referenced by the foreign key +); + +# Column names below are not used, but listed just for completeness's sake. +# Maybe we could add an option so that the user can choose which field +# names will be returned; the DBI spec is not very clear about ODBC vs. CLI. +my @FOREIGN_KEY_INFO_SQL_CLI = qw( + UK_TABLE_CAT + UK_TABLE_SCHEM + UK_TABLE_NAME + UK_COLUMN_NAME + FK_TABLE_CAT + FK_TABLE_SCHEM + FK_TABLE_NAME + FK_COLUMN_NAME + ORDINAL_POSITION + UPDATE_RULE + DELETE_RULE + FK_NAME + UK_NAME + DEFERABILITY + UNIQUE_OR_PRIMARY + ); + +sub foreign_key_info { + my $dbh = shift; + my %arg; + @arg{qw/PK_CATALOG PK_SCHEMA PK_TABLE + FK_CATALOG FK_SCHEMA FK_TABLE/} = @_; + + # check arguments + $arg{FK_TABLE} + or return $dbh->DBI::set_err($DBI::stderr, '6th arg FK_TABLE is mandatory'); + foreach my $arg_name (qw/PK_CATALOG PK_SCHEMA FK_CATALOG FK_SCHEMA/) { + !$arg{$arg_name} || $arg{$arg_name} eq '%' + or $dbh->DBI::set_err(0, "arg $arg_name will be ignored"); + } + + # get info from a PRAGMA statement + my $fk_sth = $dbh->prepare("PRAGMA foreign_key_list($arg{FK_TABLE})"); + $fk_sth->execute; + + # accumulate results (create rows of appropriate structure) + my @rows; + while (my $row = $fk_sth->fetchrow_hashref) { + next if $arg{PK_TABLE} && $arg{PK_TABLE} ne $row->{table}; + push @rows, [ + undef, # PKTABLE_CAT + undef, # PKTABLE_SCHEM + $row->{table}, # PKTABLE_NAME + $row->{to}, # PKCOLUMN_NAME + undef, # FKTABLE_CAT + undef, # FKTABLE_SCHEM + $arg{FK_TABLE}, # FKTABLE_NAME + $row->{from}, # FKCOLUMN_NAME + $row->{seq} + 1, # KEY_SEQ + $DBI_code_for_rule{$row->{on_update}}, # UPDATE_RULE + $DBI_code_for_rule{$row->{on_delete}}, # DELETE_RULE + undef, # FK_NAME + undef, # PK_NAME + undef, # DEFERRABILITY + undef, # UNIQUE_OR_PRIMARY + ]; + # not used: $row->{id}, $row->{match} + # CAVEAT : the PRAGMA does not report about DEFERRABILITY clauses + } + + # return rows as a 'sponge' statement handle + my $sponge_dbh = DBI->connect("DBI:Sponge:", '','') + or return $dbh->DBI::set_err($DBI::err, "DBI::Sponge: $DBI::errstr"); + my $sponge_sth = $sponge_dbh->prepare( "foreign_key_info $arg{FK_TABLE}", { + NAME => \@FOREIGN_KEY_INFO_ODBC, + rows => \@rows, + NUM_OF_FIELDS => scalar(@FOREIGN_KEY_INFO_ODBC), + }) or return $dbh->DBI::set_err( + $sponge_dbh->err, + $sponge_dbh->errstr, + ); + return $sponge_sth; +}; + + sub type_info_all { return; # XXX code just copied from DBD::Oracle, not yet thought about # return [ @@ -1150,6 +1265,79 @@ first argument of the mothods is usually C, and you'll usually set C for the second one (unless you want to know the primary keys of temporary tables). + +=head2 foreign_key_info + + $sth = $dbh->foreign_key_info(undef, undef, $optional_pk_table, + undef, undef, $fk_table); + +Returns information about foreign key constraints, as specified in +L, but with some limitations : + +=over + +=item * + +argument C<$fk_table> is mandatory (this is name of the table that contains +the foreign key(s)) + +=item * + +all other arguments are unused, except the optional C<$pk_table> +that may act as an additional filter (the result will only contain +the foreign keys in C<$fk_table> which correspond to C<$pk_table>'s +primary key). + +=item * + +information in rows returned by the C<$sth> is incomplete with +respect to the L specification. All requested fields +are present, but the content is C for some of them. + +=back + +The following nonempty fields are returned : + +B: +The primary (unique) key table identifier. + +B: +The primary (unique) key column identifier. + +B: +The foreign key table identifier. + +B: +The foreign key column identifier. + +B: +The column sequence number (starting with 1), when +several columns belong to a same constraint. + +B: +The referential action for the UPDATE rule. +The following codes are defined: + + CASCADE 0 + RESTRICT 1 + SET NULL 2 + NO ACTION 3 + SET DEFAULT 4 + +Default is 3 ('NO ACTION'). + +B: +The referential action for the DELETE rule. +The codes are the same as for UPDATE_RULE. + +Unfortunately, the B field is always C; +as a matter of fact, deferrability clauses are supported by SQLite, +but they can't be reported because the C +tells nothing about them. + +B: foreign key support in SQLite must be explicitly turned on through +a C command; see L earlier in this manual. + =head1 DRIVER PRIVATE METHODS The following methods can be called via the func() method with a little diff --git a/t/50_foreign_key_info.t b/t/50_foreign_key_info.t new file mode 100755 index 0000000..efc7d7d --- /dev/null +++ b/t/50_foreign_key_info.t @@ -0,0 +1,119 @@ +#!/usr/bin/perl + +use strict; +BEGIN { + $| = 1; + $^W = 1; +} + +use t::lib::Test; +use Test::More; + +BEGIN { + use DBD::SQLite; + unless ($DBD::SQLite::sqlite_version_number && $DBD::SQLite::sqlite_version_number >= 3006019) { + plan skip_all => "this test requires SQLite 3.6.19 and newer"; + exit; + } +} + +use Test::NoWarnings; + +# SQL below freely adapted from http://www.sqlite.org/foreignkeys.htm ... +# not the best datamodel in the world, but good enough for our tests. + +my @sql_statements = split /\n\n/, <<__EOSQL__; +PRAGMA foreign_keys = ON; + +CREATE TABLE artist ( + artistid INTEGER PRIMARY KEY AUTOINCREMENT, + artistname TEXT +); + +CREATE TABLE editor ( + editorid INTEGER PRIMARY KEY AUTOINCREMENT, + editorname TEXT +); + +CREATE TABLE album ( + albumartist INTEGER NOT NULL REFERENCES artist(artistid) + ON DELETE RESTRICT + ON UPDATE CASCADE, + albumname TEXT, + albumcover BINARY, + albumeditor INTEGER NOT NULL REFERENCES editor(editorid), + PRIMARY KEY(albumartist, albumname) +); + +CREATE TABLE song( + songid INTEGER PRIMARY KEY AUTOINCREMENT, + songartist INTEGER, + songalbum TEXT, + songname TEXT, + FOREIGN KEY(songartist, songalbum) REFERENCES album(albumartist, albumname) +); +__EOSQL__ + + +plan tests => @sql_statements + 17; + +my $dbh = connect_ok( RaiseError => 1, PrintError => 0, AutoCommit => 1 ); +my $sth; +my $fk_data; +my $R = \%DBD::SQLite::db::DBI_code_for_rule; + +ok ($dbh->do($_), $_) foreach @sql_statements; + +$sth = $dbh->foreign_key_info(undef, undef, undef, + undef, undef, 'album'); +$fk_data = $sth->fetchall_hashref('FKCOLUMN_NAME'); + +for ($fk_data->{albumartist}) { + is($_->{PKTABLE_NAME}, "artist" , "FK albumartist, table name"); + is($_->{PKCOLUMN_NAME}, "artistid", "FK albumartist, column name"); + is($_->{KEY_SEQ}, 1, "FK albumartist, key seq"); + is($_->{DELETE_RULE}, $R->{RESTRICT}, "FK albumartist, delete rule"); + is($_->{UPDATE_RULE}, $R->{CASCADE}, "FK albumartist, update rule"); +} +for ($fk_data->{albumeditor}) { + is($_->{PKTABLE_NAME}, "editor", "FK albumeditor, table name"); + is($_->{PKCOLUMN_NAME}, "editorid", "FK albumeditor, column name"); + is($_->{KEY_SEQ}, 1, "FK albumeditor, key seq"); + # rules are 'NO ACTION' by default + is($_->{DELETE_RULE}, $R->{'NO ACTION'}, "FK albumeditor, delete rule"); + is($_->{UPDATE_RULE}, $R->{'NO ACTION'}, "FK albumeditor, update rule"); +} + + +$sth = $dbh->foreign_key_info(undef, undef, 'artist', + undef, undef, 'album'); +$fk_data = $sth->fetchall_hashref('FKCOLUMN_NAME'); +is_deeply([keys %$fk_data], ['albumartist'], "FK album with PK, only 1 result"); + + +$sth = $dbh->foreign_key_info(undef, undef, 'foobar', + undef, undef, 'album'); +$fk_data = $sth->fetchall_hashref('FKCOLUMN_NAME'); +is_deeply([keys %$fk_data], [], "FK album with PK foobar, 0 result"); + + +$sth = $dbh->foreign_key_info(undef, undef, undef, + undef, undef, 'song'); +$fk_data = $sth->fetchall_hashref('FKCOLUMN_NAME'); +for ($fk_data->{songartist}) { + is($_->{KEY_SEQ}, 1, "FK song, key seq 1"); +} +for ($fk_data->{songalbum}) { + is($_->{KEY_SEQ}, 2, "FK song, key seq 2"); +} + +dies(sub {$dbh->foreign_key_info(undef, undef, 'artist', + undef, undef, undef)}, qr/mandatory/, + "6th arg is mandatory"); + +# use YAML; +# print STDERR Dump $fk_data; + + + +