sub foreign_key_info {
my ($dbh, $pk_catalog, $pk_schema, $pk_table, $fk_catalog, $fk_schema, $fk_table) = @_;
# Escape the schema and table name
defined and s/([\\_%])/\\$1/g for $pk_schema, $fk_schema;
my $pk_escaped = $pk_table;
$pk_escaped =~ s/([\\_%])/\\$1/g if defined $pk_escaped;
my $fk_escaped = $fk_table;
$fk_escaped =~ s/([\\_%])/\\$1/g if defined $fk_escaped;
# If pk arguments are defined, we need to fetch all tables
my $sth_tables = (defined($pk_catalog) or defined($pk_schema) or defined($pk_table))
? $dbh->table_info(undef, undef, undef, undef, {Escape => '\\'})
: $dbh->table_info($fk_catalog, $fk_schema, $fk_table, undef, {Escape => '\\'});
;
my @fk_info;
while ( my $row = $sth_tables->fetchrow_hashref ) {
my $sql = $row->{sqlite_sql} or next;
next unless $sql =~ /FOREIGN\s+KEY\s*\([^)]+\)\s*REFERENCES/si;
my $schema = $row->{TABLE_SCHEM};
my $table = $row->{TABLE_NAME};
my $have_fk_table;
if ( defined($fk_table) ) {
$have_fk_table = 1 if $table eq $fk_table;
if ( defined($fk_schema) ) {
$have_fk_table = 0 unless $schema eq $fk_schema;
}
}
my $need_both = defined($pk_table) && defined($fk_table);
my $fk_seq;
while ( $sql =~ /FOREIGN\s+KEY\((.*?)\)\s*REFERENCES\s+(.*?)\s*\((.*?)\)/gsi ) {
my ($fk_col_str, $pk_tbl, $pk_col_str) = ($1,$2,$3);
my @pk_tbl_sch = split /\./, $pk_tbl;
my $pk_sch;
if (@pk_tbl_sch > 1) {
($pk_sch, $pk_tbl) = @pk_tbl_sch;
}
$pk_sch ||= 'main';
my $have_pk_table;
if ( defined($pk_table) ) {
$have_pk_table = 1 if $pk_table eq $pk_tbl;
if ( defined($pk_schema) ) {
$have_pk_table = 0 unless $pk_schema eq $pk_sch;
}
}
next unless $have_pk_table or $have_fk_table;
next if $need_both and ( !$have_pk_table or !$have_fk_table );
s/^\s+//, s/\s+$// for $pk_col_str, $fk_col_str;
my @fk_col = split /\s*,\s*/, $fk_col_str;
my @pk_col = split /\s*,\s*/, $pk_col_str;
$fk_seq++;
for my $i (0..$#fk_col) {
push @fk_info, {
PKTABLE_SCHEM => $pk_sch,
PKTABLE_NAME => $pk_tbl,
PKCOLUMN_NAME => $pk_col[$i],
FKTABLE_SCHEM => $schema,
FKTABLE_NAME => $table,
FKCOLUMN_NAME => $fk_col[$i],
KEY_SEQ => $i+1,
UPDATE_RULE => 3,
DELETE_RULE => 3,
PK_NAME => 'PRIMARY KEY',
FK_NAME => "FK$fk_seq",
};
}
}
}
my $sponge = DBI->connect("DBI:Sponge:", '','')
or return $dbh->DBI::set_err($DBI::err, "DBI::Sponge: $DBI::errstr");
my @names = qw(
PKTABLE_CAT PKTABLE_SCHEM PKTABLE_NAME PKCOLUMN_NAME
FKTABLE_CAT FKTABLE_SCHEM FKTABLE_NAME FKCOLUMN_NAME
KEY_SEQ UPDATE_RULE DELETE_RULE PK_NAME FK_NAME
);
my $sth = $sponge->prepare( "foreign_key_info", {
rows => [ map { [ @{$_}{@names} ] } @fk_info ],
NUM_OF_FIELDS => scalar @names,
NAME => \@names,
}) or return $dbh->DBI::set_err(
$sponge->err(),
$sponge->errstr()
);
return $sth;
}
RT for rt.cpan.org