DBD::SQLite に column_info と foreign_key_info を追加する試み

表題のとおりです。まだテストをシビアに作り込んでいないので、とりあえず本体のコードを張っておくにとどめておきます。

  1. コピペするときに、最初のバグあり版 0.01 を貼ってしまっていたので、現在の版 0.02 に差し替えておきます。
  2. 0.03に。foreign_key_info の中で、指定したプライマリー・キー・テーブルが存在しないときに無駄な処理をしないようにしました。
  3. 0.04に。foreign_key_info の @fk から sqlite の管理テーブルを除去するのに map ではなく grep を使うようにしました。
package DBD::SQLite::AddInfoFunc;
use strict;
use warnings;
use DBD::SQLite;

our $VERSION = "0.04";

package DBD::SQLite::db;
use DBI qw(:sql_types);

sub pragmaall_arrayref {
    my($dbh, $f, $x, @arg) = @_;
    $f eq 'table_info'
    || $f eq 'index_list'
    || $f eq 'index_info'
    || $f eq 'foreign_key_list'
    or return [];
    local $dbh->{FetchHashKeyName} = 'NAME_lc';
    my $sth = $dbh->prepare("PRAGMA $f(@{[$dbh->quote($x)]})");
    $dbh->selectall_arrayref($sth, @arg);
}

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

sub column_info {
    my($dbh, $catalog, $schema, $table, $column) = @_;
    $column = '%' unless defined $column;
    $column =~ s/\%/\.\*/g;
    my $col_pattern = qr{\A$column\z};
    my $tables = table_infoall_arrayref($dbh, $catalog, $schema, $table, '');
    my @dbi_col_info;
    for my $tbl (@$tables) {
        my $info = pragmaall_arrayref(
            $dbh, 'table_info', $tbl->{TABLE_NAME}, {Columns=>{}}
        );
        push @dbi_col_info, map {
            $_->{name} =~ $col_pattern ? {
                TABLE_CAT => $tbl->{TABLE_CAT},
                TABLE_SCHEM => $tbl->{TABLE_SCHEM},
                TABLE_NAME => $tbl->{TABLE_NAME},
                ORDINARY_POSITION => $_->{cid} + 1,
                COLUMN_NAME => $_->{name},
                process_DATA_TYPE($_->{type}),
                ($_->{notnull}
                    ? (NULLABLE => 0, IS_NULLABLE => 'NO')
                    : (NULLABLE => 1, IS_NULLABLE => 'YES')),
                COLUMN_DEF => $_->{dflt_value},
            } : ();
        } @$info;
    }
    my @NAMES = qw(
        TABLE_CAT TABLE_SCHEM TABLE_NAME COLUMN_NAME
        DATA_TYPE TYPE_NAME COLUMN_SIZE BUFFER_LENGTH DECIMAL_DIGITS
        NUM_PREC_RADIX NULLABLE REMARKS COLUMN_DEF
        SQL_DATA_TYPE SQL_DATETIME_SUB CHAR_OCTET_LENGTH
        ORDINAL_POSITION IS_NULLABLE CHAR_SET_CAT
        CHAR_SET_SCHEM CHAR_SET_NAME COLLATION_CAT COLLATION_SCHEM COLLATION_NAME
        UDT_CAT UDT_SCHEM UDT_NAME DOMAIN_CAT DOMAIN_SCHEM DOMAIN_NAME
        SCOPE_CAT SCOPE_SCHEM SCOPE_NAME MAX_CARDINALITY
        DTD_IDENTIFIER IS_SELF_REF
    );
    my $sponge = DBI->connect('DBI:Sponge:', '','')
        or return $dbh->DBI::set_err($DBI::err, "DBI::Sponge: $DBI::errstr");
    my $sponge_sth = $sponge->prepare("column_info $table", {
        rows => [map { [@{$_}{@NAMES}] } @dbi_col_info],
        NUM_OF_FIELDS => scalar @NAMES,
        NAME => \@NAMES,
    }) or return $dbh->DBI::set_err($sponge->err(), $sponge->errstr());
    $sponge_sth;
}

sub process_DATA_TYPE {
    my($typename) = @_;
    my($basetype, $type_modifier) = $typename =~ m/\A(\w+)(?:\((.*?)\))?/;
    $basetype = uc $basetype;
    my @type_params = $type_modifier && index($type_modifier, "'") >= 0
        ? ("$type_modifier," =~ /'(.*?)',/g)
        : split /,/, $type_modifier || '';
    s/''/'/g for @type_params;
    my %info = (TYPE_NAME => $basetype, DATA_TYPE => SQL_VARCHAR());
    if ($basetype =~ /INT/) {
        $info{DATA_TYPE} = SQL_INTEGER();
        $info{NUM_PREC_RADIX} = 2;
        $info{COLUMN_SIZE} = 8;
    }
    elsif ($basetype =~ /CHAR|CLOB|TEXT|BLOB/) {
        $info{DATA_TYPE} = SQL_VARCHAR();
        $info{COLUMN_SIZE} = $type_params[0] || 4294967295;
    }
    elsif ($basetype =~ /REAL|FLOA|DOUB/) {
        $info{DATA_TYPE} = SQL_DOUBLE();
        $info{NUM_PREC_RADIX} = 2;
        $info{COLUMN_SIZE} = 8;
    }
    $info{SQL_DATA_TYPE} = $info{DATA_TYPE};
    %info;
}

sub foreign_key_info {
    my($dbh, $pkcat, $pkschem, $pktable, $fkcat, $fkschem, $fktable) = @_;
    my @fk;
    if ($fkcat || $fkschem || $fktable) {
        my $tables = table_infoall_arrayref($dbh, $fkcat, $fkschem, $fktable);
        @fk = ($tables->[0]) if @$tables == 1;
    }
    elsif ($pkcat || $pkschem || $pktable) {
        my $tables = table_infoall_arrayref($dbh, '', '', '%', '');
        @fk = grep { $_->{TABLE_NAME} !~ /\Asqlite_/ } @$tables; # 0.04 use grep instead of map.
    }
    my $pk = {
        TABLE_CAT => $pkcat,
        TABLE_SCHEM => $pkschem,
        TABLE_NAME => $pktable || '',
    };
    if ($pkcat || $pkschem || $pktable) {
        my $tables = table_infoall_arrayref($dbh, $pkcat, $pkschem, $pktable);
        if (@$tables == 1) {
            $pk = $tables->[0];
        }
        else {
            @fk = (); # 0.03: skip for-loop below.
        }
    }
    my @dbi_fk_info;
    for my $fk (@fk) {
        my $fk_info = pragmaall_arrayref(
            $dbh, 'foreign_key_list', $fk->{TABLE_NAME}, {Columns=>{}}
        );
        push @dbi_fk_info, map {
            $pk->{TABLE_NAME} && $_->{table} ne $pk->{TABLE_NAME} ? () : {
                PKTABLE_CAT => $pk->{TABLE_CAT} || $fk->{TABLE_CAT},
                PKTABLE_SCHEM => $pk->{TABLE_SCHEM} || $fk->{TABLE_SCHEM},
                PKTABLE_NAME => $_->{table},
                PKCOLUMN_NAME => $_->{to},
                FKTABLE_CAT => $fk->{TABLE_CAT},
                FKTABLE_SCHEM => $fk->{TABLE_SCHEM},
                FKTABLE_NAME => $fk->{TABLE_NAME},
                FKCOLUMN_NAME => $_->{from},
                KEY_SEQ => $_->{seq} + 1,
            };
        } @$fk_info;
    }
    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;

__END__

=head1 NAME

    DBD::SQLite::AddInfoFunc -- add column_info and foreign_key_info

=head1 USAGE

    use DBD::SQLite::AddInfoFunc;
    use DBI;
    
    unlink "test.db" if -e "test.db";
    my $dbh = DBI->connect("dbi:SQLite:dbname=test.db");

    $dbh->do(<<'SQL');
    CREATE TABLE product (
        category INTEGER NOT NULL
       ,id INTEGER NOT NULL
       ,PRIMARY KEY(category, id)
    );
    SQL
    $dbh->do(<<'SQL');
    CREATE TABLE customer (
        id INTEGER NOT NULL
       ,PRIMARY KEY (id)
    );
    SQL
    $dbh->do(<<'SQL');
    CREATE TABLE product_order (
        no INTEGER NOT NULL PRIMARY KEY AUTOINCREMENT
       ,product_category INTEGER NOT NULL
       ,product_id INTEGER NOT NULL
       ,customer_id INTEGER NOT NULL
       ,FOREIGN KEY (product_category, product_id) REFERENCES product(category, id)
            ON UPDATE CASCADE
            ON DELETE RESTRICT
       ,FOREIGN KEY (customer_id) REFERENCES customer(id)
    );
    SQL

    if (my $sth = $dbh->column_info('', '', 'product', '%')) {
        my $col_info = $dbh->selectall_arrayref($sth, {Columns => {}});
    }
    if (my $sth = $dbh->column_info('', '', 'product', 'category')) {
        my $col_info = $dbh->selectall_arrayref($sth, {Columns => {}});
    }
    if (my $sth = $dbh->foreign_key_info('', '', 'product', '', '', 'product_order')) {
        my $fk_info = $dbh->selectall_arrayref($sth, {Columns => {}});
    }
    if (my $sth = $dbh->foreign_key_info('', '', 'product', '', '', '')) {
        my $fk_info = $dbh->selectall_arrayref($sth, {Columns => {}});
    }
    if (my $sth = $dbh->foreign_key_info('', '', '', '', '', 'product_order')) {
        my $fk_info = $dbh->selectall_arrayref($sth, {Columns => {}});
    }
    
    $dbh->disconnect;

=head1 AUTHOR

MIZUTANI, Tociyuki, E<lt>tociyuki\100gmail.comE<gt>

=head1 COPYRIGHT AND LICENSE

Copyright (C) 2008 by MIZUTANI, Tociyuki

This library is free software; you can redistribute it
and/or modify it under the same terms as Perl itself.

=cut