foreign_key_info() implementation

See below for an implementation of foreign_key_info(). The _version()
thing is lame, just like in my last patch ;)


sub_foreign_key_info {
my ($dbh,
$pk_catalog, $pk_schema, $pk_table,
undef, $fk_schema, $fk_table,
) = @_;

local $dbh->{FetchHashKeyName} = 'NAME_lc';

my ($maj, $min, $point) = _version($dbh);

return unless $maj >= 5 && $point >= 6;

my @names = 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 DELETE_RULE FK_NAME UK_NAME DEFERABILITY
UNIQUE_OR_PRIMARY
);

my $sql = <<'EOF';
SELECT TABLE_CATALOG AS UK_TABLE_CAT,
TABLE_SCHEMA AS UK_TABLE_SCHEM,
TABLE_NAME AS UK_TABLE_NAME,
COLUMN_NAME AS UK_COLUMN_NAME,
NULL AS FK_TABLE_CAT,
REFERENCED_TABLE_SCHEMA AS FK_TABLE_SCHEM,
REFERENCED_TABLE_NAME AS FK_TABLE_NAME,
REFERENCED_COLUMN_NAME AS FK_COLUMN_NAME,
ORDINAL_POSITION,
NULL AS DELETE_RULE,
CONSTRAINT_NAME AS FK_NAME,
NULL AS UK_NAME,
NULL AS DEFERABILITY,
NULL AS UNIQUE_OR_PRIMARY
FROM INFORMATION_SCHEMA.KEY_COLUMN_USAGE
WHERE REFERENCED_TABLE_NAME IS NOT NULL
EOF

my @where;
my @bind;

if ( defined $pk_catalog ) {
push @where, 'TABLE_CATALOG LIKE ?';
push @bind, $pk_catalog;
}

if ( defined $pk_schema ) {
push @where, 'TABLE_SCHEMA LIKE ?';
push @bind, $pk_schema;
}

if ( defined $pk_table ) {
push @where, 'TABLE_NAME LIKE ?';
push @bind, $pk_table;
}

if ( defined $fk_schema ) {
push @where, 'REFERENCED_TABLE_SCHEMA LIKE ?';
push @bind, $fk_schema;
}

if ( defined $fk_table ) {
push @where, 'REFERENCED_TABLE_NAME LIKE ?';
push @bind, $fk_table;
}

if (@where) {
$sql .= ' AND ';
$sql .= join ' AND ', @where;
}

local $dbh->{FetchHashKeyName} = 'NAME_uc';
my $sth = $dbh->prepare($sql);
$sth->execute(@bind);

return $sth;
}

sub _version {
my $dbh = shift;

return
$dbh->get_info($DBI::Const::GetInfoType::GetInfoType{SQL_DBM S_VER})
=~ /(\d+)\.(\d+)\.(\d+)/;
}



/*===================================================
VegGuide.Org www.BookIRead.com
Your guide to all that's veg. My book blog
===================================================*/

--
MySQL Perl Mailing List
For list archives: http://lists.mysql.com/perl
To unsubscribe: http://lists.mysql.com/perl?unsub=gcdmp-msql-mysql-modules@m .gmane.org