view release on metacpan or  search on metacpan

lib/DBD/SQLite.pm  view on Meta::CPAN

}


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
 );

my $DEFERRABLE_RE = qr/
    (?:(?:
        on \s+ (?:delete|update) \s+ (?:set \s+ null|set \s+ default|cascade|restrict|no \s+ action)
    |
        match \s* (?:\S+|".+?(?<!")")
    ) \s*)*
    ((?:not)? \s* deferrable (?: \s* initially \s* (?: immediate | deferred))?)?
/sxi;

sub foreign_key_info {
    my ($dbh, $pk_catalog, $pk_schema, $pk_table, $fk_catalog, $fk_schema, $fk_table) = @_;

    my $databases = $dbh->selectall_arrayref("PRAGMA database_list", {Slice => {}}) or return;

    my @fk_info;
    my %table_info;
    for my $database (@$databases) {
        my $dbname = $database->{name};
        next if defined $fk_schema && $fk_schema ne '%' && $fk_schema ne $dbname;

        my $quoted_dbname = $dbh->quote_identifier($dbname);
        my $master_table =
            ($dbname eq 'main') ? 'sqlite_master' :
            ($dbname eq 'temp') ? 'sqlite_temp_master' :
            $quoted_dbname.'.sqlite_master';

        my $tables = $dbh->selectall_arrayref("SELECT name, sql FROM $master_table WHERE type = ?", undef, "table") or return;
        for my $table (@$tables) {
            my $tbname = $table->[0];
            my $ddl = $table->[1];
            my (@rels, %relid2rels);
            next if defined $fk_table && $fk_table ne '%' && $fk_table ne $tbname;

            my $quoted_tbname = $dbh->quote_identifier($tbname);
            my $sth = $dbh->prepare("PRAGMA $quoted_dbname.foreign_key_list($quoted_tbname)") or return;
            $sth->execute or return;
            while(my $row = $sth->fetchrow_hashref) {
                next if defined $pk_table && $pk_table ne '%' && $pk_table ne $row->{table};

                unless ($table_info{$row->{table}}) {
                    my $quoted_tb = $dbh->quote_identifier($row->{table});
                    for my $db (@$databases) {
                        my $quoted_db = $dbh->quote_identifier($db->{name});
                        my $t_sth = $dbh->prepare("PRAGMA $quoted_db.table_xinfo($quoted_tb)") or return;
                        $t_sth->execute or return;
                        my $cols = {};
                        while(my $r = $t_sth->fetchrow_hashref) {
                            $cols->{$r->{name}} = $r->{pk};
                        }
                        if (keys %$cols) {
                            $table_info{$row->{table}} = {
                                schema  => $db->{name},
                                columns => $cols,
                            };
                            last;
                        }
                    }
                }

                next if defined $pk_schema && $pk_schema ne '%' && $pk_schema ne $table_info{$row->{table}}{schema};

                # cribbed from DBIx::Class::Schema::Loader::DBI::SQLite
                my $rel = $rels[ $row->{id} ] ||= {