The Perl Toolchain Summit needs more sponsors. If your company depends on Perl, please support this very important event.
package DBIx::Inspector::Driver::SQLite;
use strict;
use warnings;
use utf8;
use base qw/DBIx::Inspector::Driver::Base/;

sub foreign_keys {
    my ($self, @args) = @_;

    local *DBD::SQLite::db::foreign_key_info = \&_dbd_sqlite_foreign_key_info_monkey_patch;
    return $self->SUPER::foreign_keys(@args);
}

sub table_infoall_arrayref {
    my $dbh = shift;
    my $sth = $dbh->table_info(@_) or return [];
    $dbh->selectall_arrayref( $sth, { Columns => {} } ) or [];
}

sub _dbd_sqlite_foreign_key_info_monkey_patch {
    my($dbh, $pkcat, $pkschem, $pktable, $fkcat, $fkschem, $fktable) = @_;

    my $sth = $dbh->table_info(undef, $fkschem, $fktable || '%', 'TABLE') or return;

    my @dbi_fk_info;
    while (my $table = $sth->fetchrow_hashref()) {
        next if $table->{TABLE_NAME} =~ /\Asqlite_/;
        next unless (!defined $fktable) || $fktable eq '%' || $fktable eq $table->{TABLE_NAME};

        local $dbh->{FetchHashKeyName} = 'NAME_lc';
        my $sth = $dbh->prepare(sprintf(q{PRAGMA foreign_key_list(%s)}, $dbh->quote($table->{TABLE_NAME}))) or die $dbh->errstr;
        $sth->execute();
        while (my $fk = $sth->fetchrow_hashref()) {
            next unless !defined($pktable) || $pktable eq '%' || $pktable eq $fk->{table};
            push @dbi_fk_info, +{
                PKTABLE_CAT => undef,
                PKTABLE_SCHEM => undef, # TODO
                PKTABLE_NAME  => $fk->{table},
                PKCOLUMN_NAME => $fk->{to},
                FSKTABLE_CAT  => $table->{TABLE_CAT},
                FKTABLE_SCHEM => $table->{TABLE_SCHEM},
                FKTABLE_NAME  => $table->{TABLE_NAME},
                FKCOLUMN_NAME => $fk->{from},
                KEY_SEQ       => $fk->{seq},
            };
        }
    }

    my @NAMES = qw(
        PKTABLE_CAT PKTABLE_SCHEM PKTABLE_NAME PKCOLUMN_NAME PK_NAME
        FKTABLE_CAT FKTABLE_SCHEM FKTABLE_NAME FKCOLUMN_NAME FK_NAME
        KEY_SEQ UPDATE_RULE DELETE_RULE DEFERRABILITY
    );
    my $sponge = DBI->connect('DBI:Sponge:', '','')
        or return $dbh->DBI::set_err($DBI::err, "DBI::Sponge: $DBI::errstr");
    my $sponge_sth = $sponge->prepare("foreign_key_info", {
        rows => [map { [@{$_}{@NAMES}] } @dbi_fk_info],
        NUM_OF_FIELDS => scalar @NAMES,
        NAME => \@NAMES,
    }) or return $dbh->DBI::set_err($sponge->err(), $sponge->errstr());
    $sponge_sth;
}

1;