[dbsrgits/DBIx-Class-Schema-Loader.git] / lib / DBIx / Class / Schema / Loader / DBI.pm

package DBIx::Class::Schema::Loader::DBI;

use strict;
use warnings;
use base qw/DBIx::Class::Schema::Loader::Base/;
use Class::C3;
use Carp::Clan qw/^DBIx::Class/;

our $VERSION = '0.07000';

=head1 NAME

DBIx::Class::Schema::Loader::DBI - DBIx::Class::Schema::Loader DBI Implementation.

=head1 SYNOPSIS

See L<DBIx::Class::Schema::Loader::Base>

=head1 DESCRIPTION

This is the base class for L<DBIx::Class::Schema::Loader::Base> classes for
DBI-based storage backends, and implements the common functionality between them.

See L<DBIx::Class::Schema::Loader::Base> for the available options.

=head1 METHODS

=head2 new

Overlays L<DBIx::Class::Schema::Loader::Base/new> to do some DBI-specific
things.

=cut

sub new {
    my $self = shift->next::method(@_);

    # rebless to vendor-specific class if it exists and loads and we're not in a
    # custom class.
    if (not $self->loader_class) {
        my $dbh = $self->schema->storage->dbh;
        my $driver = $dbh->{Driver}->{Name};

        my $subclass = 'DBIx::Class::Schema::Loader::DBI::' . $driver;
        if ($self->load_optional_class($subclass)) {
            bless $self, $subclass unless $self->isa($subclass);
            $self->_rebless;
        }
    }

    # Set up the default quoting character and name seperators
    $self->{_quoter}  = $self->_build_quoter;
    $self->{_namesep} = $self->_build_namesep;

    # For our usage as regex matches, concatenating multiple quoter
    # values works fine (e.g. s/\Q<>\E// if quoter was [ '<', '>' ])
    if( ref $self->{_quoter} eq 'ARRAY') {
        $self->{_quoter} = join(q{}, @{$self->{_quoter}});
    }

    $self->_setup;

    $self;
}

sub _build_quoter {
    my $self = shift;
    my $dbh = $self->schema->storage->dbh;
    return $dbh->get_info(29)
           || $self->schema->storage->sql_maker->quote_char
           || q{"};
}

sub _build_namesep {
    my $self = shift;
    my $dbh = $self->schema->storage->dbh;
    return $dbh->get_info(41)
           || $self->schema->storage->sql_maker->name_sep
           || q{.};
}

# Override this in vendor modules to do things at the end of ->new()
sub _setup { }

# Override this in vendor module to load a subclass if necessary
sub _rebless { }

# Returns an array of table names
sub _tables_list { 
    my ($self, $opts) = (shift, shift);

    my ($table, $type) = @_ ? @_ : ('%', '%');

    my $dbh = $self->schema->storage->dbh;
    my @tables = $dbh->tables(undef, $self->db_schema, $table, $type);

    my $qt = qr/[\Q$self->{_quoter}\E"'`\[\]]/;

    my $all_tables_quoted = (grep /$qt/, @tables) == @tables;

    if ($self->{_quoter} && $all_tables_quoted) {
        s/.* $qt (?= .* $qt)//xg for @tables;
    } else {
        s/^.*\Q$self->{_namesep}\E// for @tables;
    }
    s/$qt//g for @tables;

    return $self->_filter_tables(\@tables, $opts);
}

# apply constraint/exclude and ignore bad tables and views
sub _filter_tables {
    my ($self, $tables, $opts) = @_;

    my @tables = @$tables;
    my @filtered_tables;

    $opts ||= {};
    my $constraint   = $opts->{constraint};
    my $exclude      = $opts->{exclude};

    @tables = grep { /$constraint/ } @$tables if defined $constraint;
    @tables = grep { ! /$exclude/  } @$tables if defined $exclude;

    for my $table (@tables) {
        eval {
            my $sth = $self->_sth_for($table, undef, \'1 = 0');
            $sth->execute;
        };
        if (not $@) {
            push @filtered_tables, $table;
        }
        else {
            warn "Bad table or view '$table', ignoring: $@\n";
            local $@;
            eval {
                my $schema = $self->schema;
                # in older DBIC it's a private method
                my $unregister = $schema->can('unregister_source')
                    || $schema->can('_unregister_source');
                $schema->$unregister($self->_table2moniker($table));
            };
        }
    }

    return @filtered_tables;
}

=head2 load

We override L<DBIx::Class::Schema::Loader::Base/load> here to hook in our localized settings for C<$dbh> error handling.

=cut

sub load {
    my $self = shift;

    local $self->schema->storage->dbh->{RaiseError} = 1;
    local $self->schema->storage->dbh->{PrintError} = 0;
    $self->next::method(@_);
}

sub _table_as_sql {
    my ($self, $table) = @_;

    if($self->{db_schema}) {
        $table = $self->{db_schema} . $self->{_namesep} .
            $self->_quote_table_name($table);
    } else {
        $table = $self->_quote_table_name($table);
    }

    return $table;
}

sub _sth_for {
    my ($self, $table, $fields, $where) = @_;

    my $dbh = $self->schema->storage->dbh;

    my $sth = $dbh->prepare($self->schema->storage->sql_maker
        ->select(\$self->_table_as_sql($table), $fields, $where));

    return $sth;
}

# Returns an arrayref of column names
sub _table_columns {
    my ($self, $table) = @_;

    my $sth = $self->_sth_for($table, undef, \'1 = 0');
    $sth->execute;
    my $retval = $self->preserve_case ? \@{$sth->{NAME}} : \@{$sth->{NAME_lc}};
    $sth->finish;

    $retval;
}

# Returns arrayref of pk col names
sub _table_pk_info { 
    my ($self, $table) = @_;

    my $dbh = $self->schema->storage->dbh;

    my @primary = map { lc } $dbh->primary_key('', $self->db_schema, $table);
    s/\Q$self->{_quoter}\E//g for @primary;

    return \@primary;
}

# Override this for vendor-specific uniq info
sub _table_uniq_info {
    my ($self, $table) = @_;

    my $dbh = $self->schema->storage->dbh;
    if(!$dbh->can('statistics_info')) {
        warn "No UNIQUE constraint information can be gathered for this vendor";
        return [];
    }

    my %indices;
    my $sth = $dbh->statistics_info(undef, $self->db_schema, $table, 1, 1);
    while(my $row = $sth->fetchrow_hashref) {
        # skip table-level stats, conditional indexes, and any index missing
        #  critical fields
        next if $row->{TYPE} eq 'table'
            || defined $row->{FILTER_CONDITION}
            || !$row->{INDEX_NAME}
            || !defined $row->{ORDINAL_POSITION}
            || !$row->{COLUMN_NAME};

        $indices{$row->{INDEX_NAME}}->{$row->{ORDINAL_POSITION}} = $row->{COLUMN_NAME};
    }
    $sth->finish;

    my @retval;
    foreach my $index_name (keys %indices) {
        my $index = $indices{$index_name};
        push(@retval, [ $index_name => [
            map { $index->{$_} }
                sort keys %$index
        ]]);
    }

    return \@retval;
}

# Find relationships
sub _table_fk_info {
    my ($self, $table) = @_;

    my $dbh = $self->schema->storage->dbh;
    my $sth = $dbh->foreign_key_info( '', $self->db_schema, '',
                                      '', $self->db_schema, $table );
    return [] if !$sth;

    my %rels;

    my $i = 1; # for unnamed rels, which hopefully have only 1 column ...
    while(my $raw_rel = $sth->fetchrow_arrayref) {
        my $uk_tbl  = $raw_rel->[2];
        my $uk_col  = lc $raw_rel->[3];
        my $fk_col  = lc $raw_rel->[7];
        my $relid   = ($raw_rel->[11] || ( "__dcsld__" . $i++ ));
        $uk_tbl =~ s/\Q$self->{_quoter}\E//g;
        $uk_col =~ s/\Q$self->{_quoter}\E//g;
        $fk_col =~ s/\Q$self->{_quoter}\E//g;
        $relid  =~ s/\Q$self->{_quoter}\E//g;
        $rels{$relid}->{tbl} = $uk_tbl;
        $rels{$relid}->{cols}->{$uk_col} = $fk_col;
    }
    $sth->finish;

    my @rels;
    foreach my $relid (keys %rels) {
        push(@rels, {
            remote_columns => [ keys   %{$rels{$relid}->{cols}} ],
            local_columns  => [ values %{$rels{$relid}->{cols}} ],
            remote_table   => $rels{$relid}->{tbl},
        });
    }

    return \@rels;
}

# ported in from DBIx::Class::Storage::DBI:
sub _columns_info_for {
    my ($self, $table) = @_;

    my $dbh = $self->schema->storage->dbh;

    if ($dbh->can('column_info')) {
        my %result;
        eval {
            my $sth = eval { local $SIG{__WARN__} = sub {}; $dbh->column_info( undef, $self->db_schema, $table, '%' ); };
            while ( my $info = $sth->fetchrow_hashref() ){
                my $column_info = {};
                $column_info->{data_type}     = lc $info->{TYPE_NAME};

                my $size = $info->{COLUMN_SIZE};

                if (defined $size && defined $info->{DECIMAL_DIGITS}) {
                    $column_info->{size} = [$size, $info->{DECIMAL_DIGITS}];
                }
                elsif (defined $size) {
                    $column_info->{size} = $size;
                }

                $column_info->{is_nullable}   = $info->{NULLABLE} ? 1 : 0;
                $column_info->{default_value} = $info->{COLUMN_DEF} if defined $info->{COLUMN_DEF};
                my $col_name = $info->{COLUMN_NAME};
                $col_name =~ s/^\"(.*)\"$/$1/;

                my $extra_info = $self->_extra_column_info(
                    $table, $col_name, $column_info, $info
                ) || {};
                $column_info = { %$column_info, %$extra_info };

                $result{$col_name} = $column_info;
            }
            $sth->finish;
        };
      return \%result if !$@ && scalar keys %result;
    }

    my %result;
    my $sth = $self->_sth_for($table, undef, \'1 = 0');
    $sth->execute;
    my @columns = @{ $self->preserve_case ? $sth->{NAME} : $sth->{NAME_lc} };
    for my $i ( 0 .. $#columns ){
        my $column_info = {};
        $column_info->{data_type} = lc $sth->{TYPE}->[$i];

        my $size = $sth->{PRECISION}[$i];

        if (defined $size && defined $sth->{SCALE}[$i]) {
            $column_info->{size} = [$size, $sth->{SCALE}[$i]];
        }
        elsif (defined $size) {
            $column_info->{size} = $size;
        }

        $column_info->{is_nullable} = $sth->{NULLABLE}->[$i] ? 1 : 0;

        if ($column_info->{data_type} =~ m/^(.*?)\((.*?)\)$/) {
            $column_info->{data_type} = $1;
            $column_info->{size}    = $2;
        }

        my $extra_info = $self->_extra_column_info($table, $columns[$i], $column_info) || {};
        $column_info = { %$column_info, %$extra_info };

        $result{$columns[$i]} = $column_info;
    }
    $sth->finish;

    foreach my $col (keys %result) {
        my $colinfo = $result{$col};
        my $type_num = $colinfo->{data_type};
        my $type_name;
        if(defined $type_num && $type_num =~ /^\d+\z/ && $dbh->can('type_info')) {
            my $type_info = $dbh->type_info($type_num);
            $type_name = $type_info->{TYPE_NAME} if $type_info;
            $colinfo->{data_type} = lc $type_name if $type_name;
        }
    }

    return \%result;
}

# Override this in vendor class to return any additional column
# attributes
sub _extra_column_info {}

=head1 SEE ALSO

L<DBIx::Class::Schema::Loader>

=head1 AUTHOR

See L<DBIx::Class::Schema::Loader/AUTHOR> and L<DBIx::Class::Schema::Loader/CONTRIBUTORS>.

=head1 LICENSE

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

=cut

1;
# vim:et sts=4 sw=4 tw=0:
Commit	Line	Data
996be9ee	1	package DBIx::Class::Schema::Loader::DBI;
	2
	3	use strict;
	4	use warnings;
abaf2c66	5	use base qw/DBIx::Class::Schema::Loader::Base/;
996be9ee	6	use Class::C3;
fa994d3c	7	use Carp::Clan qw/^DBIx::Class/;
996be9ee	8
9990e58f	9	our $VERSION = '0.07000';
32f784fc	10
996be9ee	11	=head1 NAME
	12
	13	DBIx::Class::Schema::Loader::DBI - DBIx::Class::Schema::Loader DBI Implementation.
	14
	15	=head1 SYNOPSIS
	16
	17	See L<DBIx::Class::Schema::Loader::Base>
	18
	19	=head1 DESCRIPTION
	20
	21	This is the base class for L<DBIx::Class::Schema::Loader::Base> classes for
	22	DBI-based storage backends, and implements the common functionality between them.
	23
	24	See L<DBIx::Class::Schema::Loader::Base> for the available options.
	25
	26	=head1 METHODS
	27
	28	=head2 new
	29
	30	Overlays L<DBIx::Class::Schema::Loader::Base/new> to do some DBI-specific
	31	things.
	32
	33	=cut
	34
	35	sub new {
	36	my $self = shift->next::method(@_);
	37
71a6e88a	38	# rebless to vendor-specific class if it exists and loads and we're not in a
	39	# custom class.
	40	if (not $self->loader_class) {
	41	my $dbh = $self->schema->storage->dbh;
	42	my $driver = $dbh->{Driver}->{Name};
	43
	44	my $subclass = 'DBIx::Class::Schema::Loader::DBI::' . $driver;
	45	if ($self->load_optional_class($subclass)) {
	46	bless $self, $subclass unless $self->isa($subclass);
	47	$self->_rebless;
	48	}
996be9ee	49	}
	50
	51	# Set up the default quoting character and name seperators
243c6ebc	52	$self->{_quoter} = $self->_build_quoter;
77d3753e	53	$self->{_namesep} = $self->_build_namesep;
243c6ebc	54
996be9ee	55	# For our usage as regex matches, concatenating multiple quoter
	56	# values works fine (e.g. s/\Q<>\E// if quoter was [ '<', '>' ])
	57	if( ref $self->{_quoter} eq 'ARRAY') {
	58	$self->{_quoter} = join(q{}, @{$self->{_quoter}});
	59	}
	60
	61	$self->_setup;
	62
	63	$self;
	64	}
	65
77d3753e	66	sub _build_quoter {
	67	my $self = shift;
	68	my $dbh = $self->schema->storage->dbh;
	69	return $dbh->get_info(29)
	70	\|\| $self->schema->storage->sql_maker->quote_char
	71	\|\| q{"};
	72	}
	73
	74	sub _build_namesep {
	75	my $self = shift;
	76	my $dbh = $self->schema->storage->dbh;
	77	return $dbh->get_info(41)
	78	\|\| $self->schema->storage->sql_maker->name_sep
	79	\|\| q{.};
	80	}
	81
996be9ee	82	# Override this in vendor modules to do things at the end of ->new()
	83	sub _setup { }
	84
6ae3f335	85	# Override this in vendor module to load a subclass if necessary
	86	sub _rebless { }
	87
996be9ee	88	# Returns an array of table names
996be9ee	89	sub _tables_list {
bfb43060	90	my ($self, $opts) = (shift, shift);
996be9ee	91
e57fd726	92	my ($table, $type) = @_ ? @_ : ('%', '%');
e57fd726	93
996be9ee	94	my $dbh = $self->schema->storage->dbh;
e57fd726	95	my @tables = $dbh->tables(undef, $self->db_schema, $table, $type);
77d3753e	96
c5ff1f26	97	my $qt = qr/[\Q$self->{_quoter}\E"'`\[\]]/;
385c593b	98
c5ff1f26	99	my $all_tables_quoted = (grep /$qt/, @tables) == @tables;
	100
	101	if ($self->{_quoter} && $all_tables_quoted) {
385c593b	102	s/.* $qt (?= .* $qt)//xg for @tables;
	103	} else {
	104	s/^.*\Q$self->{_namesep}\E// for @tables;
	105	}
	106	s/$qt//g for @tables;
996be9ee	107
bfb43060	108	return $self->_filter_tables(\@tables, $opts);
075aff97	109	}
075aff97	110
bfb43060	111	# apply constraint/exclude and ignore bad tables and views
075aff97	112	sub _filter_tables {
bfb43060	113	my ($self, $tables, $opts) = @_;
075aff97	114
bfb43060	115	my @tables = @$tables;
075aff97	116	my @filtered_tables;
075aff97	117
bfb43060	118	$opts \|\|= {};
	119	my $constraint = $opts->{constraint};
	120	my $exclude = $opts->{exclude};
	121
	122	@tables = grep { /$constraint/ } @$tables if defined $constraint;
	123	@tables = grep { ! /$exclude/ } @$tables if defined $exclude;
	124
075aff97	125	for my $table (@tables) {
805dbe0a	126	eval {
	127	my $sth = $self->_sth_for($table, undef, \'1 = 0');
	128	$sth->execute;
	129	};
075aff97	130	if (not $@) {
	131	push @filtered_tables, $table;
	132	}
	133	else {
	134	warn "Bad table or view '$table', ignoring: $@\n";
d073740e	135	local $@;
	136	eval {
	137	my $schema = $self->schema;
	138	# in older DBIC it's a private method
	139	my $unregister = $schema->can('unregister_source')
	140	\|\| $schema->can('_unregister_source');
	141	$schema->$unregister($self->_table2moniker($table));
	142	};
075aff97	143	}
	144	}
	145
	146	return @filtered_tables;
996be9ee	147	}
996be9ee	148
12af3806	149	=head2 load
	150
	151	We override L<DBIx::Class::Schema::Loader::Base/load> here to hook in our localized settings for C<$dbh> error handling.
	152
	153	=cut
	154
	155	sub load {
	156	my $self = shift;
	157
	158	local $self->schema->storage->dbh->{RaiseError} = 1;
	159	local $self->schema->storage->dbh->{PrintError} = 0;
	160	$self->next::method(@_);
	161	}
	162
075aff97	163	sub _table_as_sql {
996be9ee	164	my ($self, $table) = @_;
996be9ee	165
996be9ee	166	if($self->{db_schema}) {
385c593b	167	$table = $self->{db_schema} . $self->{_namesep} .
	168	$self->_quote_table_name($table);
	169	} else {
	170	$table = $self->_quote_table_name($table);
996be9ee	171	}
996be9ee	172
075aff97	173	return $table;
	174	}
	175
	176	sub _sth_for {
	177	my ($self, $table, $fields, $where) = @_;
	178
	179	my $dbh = $self->schema->storage->dbh;
	180
	181	my $sth = $dbh->prepare($self->schema->storage->sql_maker
	182	->select(\$self->_table_as_sql($table), $fields, $where));
	183
	184	return $sth;
	185	}
	186
	187	# Returns an arrayref of column names
	188	sub _table_columns {
	189	my ($self, $table) = @_;
	190
	191	my $sth = $self->_sth_for($table, undef, \'1 = 0');
996be9ee	192	$sth->execute;
bc1cb85e	193	my $retval = $self->preserve_case ? \@{$sth->{NAME}} : \@{$sth->{NAME_lc}};
3b7f80f9	194	$sth->finish;
	195
	196	$retval;
996be9ee	197	}
	198
	199	# Returns arrayref of pk col names
	200	sub _table_pk_info {
fd589700	201	my ($self, $table) = @_;
996be9ee	202
	203	my $dbh = $self->schema->storage->dbh;
	204
	205	my @primary = map { lc } $dbh->primary_key('', $self->db_schema, $table);
	206	s/\Q$self->{_quoter}\E//g for @primary;
	207
	208	return \@primary;
	209	}
	210
fd589700	211	# Override this for vendor-specific uniq info
996be9ee	212	sub _table_uniq_info {
fd589700	213	my ($self, $table) = @_;
	214
	215	my $dbh = $self->schema->storage->dbh;
	216	if(!$dbh->can('statistics_info')) {
	217	warn "No UNIQUE constraint information can be gathered for this vendor";
	218	return [];
	219	}
	220
	221	my %indices;
	222	my $sth = $dbh->statistics_info(undef, $self->db_schema, $table, 1, 1);
	223	while(my $row = $sth->fetchrow_hashref) {
	224	# skip table-level stats, conditional indexes, and any index missing
	225	# critical fields
	226	next if $row->{TYPE} eq 'table'
	227	\|\| defined $row->{FILTER_CONDITION}
	228	\|\| !$row->{INDEX_NAME}
	229	\|\| !defined $row->{ORDINAL_POSITION}
	230	\|\| !$row->{COLUMN_NAME};
	231
	232	$indices{$row->{INDEX_NAME}}->{$row->{ORDINAL_POSITION}} = $row->{COLUMN_NAME};
	233	}
3b7f80f9	234	$sth->finish;
fd589700	235
	236	my @retval;
	237	foreach my $index_name (keys %indices) {
	238	my $index = $indices{$index_name};
	239	push(@retval, [ $index_name => [
	240	map { $index->{$_} }
	241	sort keys %$index
	242	]]);
	243	}
	244
	245	return \@retval;
996be9ee	246	}
	247
	248	# Find relationships
	249	sub _table_fk_info {
	250	my ($self, $table) = @_;
	251
	252	my $dbh = $self->schema->storage->dbh;
a168c1c4	253	my $sth = $dbh->foreign_key_info( '', $self->db_schema, '',
a168c1c4	254	'', $self->db_schema, $table );
996be9ee	255	return [] if !$sth;
	256
	257	my %rels;
	258
	259	my $i = 1; # for unnamed rels, which hopefully have only 1 column ...
	260	while(my $raw_rel = $sth->fetchrow_arrayref) {
	261	my $uk_tbl = $raw_rel->[2];
	262	my $uk_col = lc $raw_rel->[3];
	263	my $fk_col = lc $raw_rel->[7];
	264	my $relid = ($raw_rel->[11] \|\| ( "__dcsld__" . $i++ ));
	265	$uk_tbl =~ s/\Q$self->{_quoter}\E//g;
	266	$uk_col =~ s/\Q$self->{_quoter}\E//g;
	267	$fk_col =~ s/\Q$self->{_quoter}\E//g;
	268	$relid =~ s/\Q$self->{_quoter}\E//g;
	269	$rels{$relid}->{tbl} = $uk_tbl;
	270	$rels{$relid}->{cols}->{$uk_col} = $fk_col;
	271	}
3b7f80f9	272	$sth->finish;
996be9ee	273
	274	my @rels;
	275	foreach my $relid (keys %rels) {
	276	push(@rels, {
	277	remote_columns => [ keys %{$rels{$relid}->{cols}} ],
	278	local_columns => [ values %{$rels{$relid}->{cols}} ],
	279	remote_table => $rels{$relid}->{tbl},
	280	});
	281	}
	282
	283	return \@rels;
	284	}
	285
12af3806	286	# ported in from DBIx::Class::Storage::DBI:
	287	sub _columns_info_for {
	288	my ($self, $table) = @_;
	289
	290	my $dbh = $self->schema->storage->dbh;
	291
	292	if ($dbh->can('column_info')) {
	293	my %result;
	294	eval {
26334ec1	295	my $sth = eval { local $SIG{__WARN__} = sub {}; $dbh->column_info( undef, $self->db_schema, $table, '%' ); };
12af3806	296	while ( my $info = $sth->fetchrow_hashref() ){
23d1f36b	297	my $column_info = {};
26334ec1	298	$column_info->{data_type} = lc $info->{TYPE_NAME};
	299
	300	my $size = $info->{COLUMN_SIZE};
	301
	302	if (defined $size && defined $info->{DECIMAL_DIGITS}) {
	303	$column_info->{size} = [$size, $info->{DECIMAL_DIGITS}];
	304	}
	305	elsif (defined $size) {
	306	$column_info->{size} = $size;
	307	}
	308
23d1f36b	309	$column_info->{is_nullable} = $info->{NULLABLE} ? 1 : 0;
df956aad	310	$column_info->{default_value} = $info->{COLUMN_DEF} if defined $info->{COLUMN_DEF};
12af3806	311	my $col_name = $info->{COLUMN_NAME};
	312	$col_name =~ s/^\"(.*)\"$/$1/;
	313
45be2ce7	314	my $extra_info = $self->_extra_column_info(
	315	$table, $col_name, $column_info, $info
	316	) \|\| {};
23d1f36b	317	$column_info = { %$column_info, %$extra_info };
23d1f36b	318
23d1f36b	319	$result{$col_name} = $column_info;
12af3806	320	}
3b7f80f9	321	$sth->finish;
12af3806	322	};
	323	return \%result if !$@ && scalar keys %result;
	324	}
	325
12af3806	326	my %result;
075aff97	327	my $sth = $self->_sth_for($table, undef, \'1 = 0');
12af3806	328	$sth->execute;
bc1cb85e	329	my @columns = @{ $self->preserve_case ? $sth->{NAME} : $sth->{NAME_lc} };
12af3806	330	for my $i ( 0 .. $#columns ){
23d1f36b	331	my $column_info = {};
26334ec1	332	$column_info->{data_type} = lc $sth->{TYPE}->[$i];
	333
	334	my $size = $sth->{PRECISION}[$i];
	335
	336	if (defined $size && defined $sth->{SCALE}[$i]) {
	337	$column_info->{size} = [$size, $sth->{SCALE}[$i]];
	338	}
	339	elsif (defined $size) {
	340	$column_info->{size} = $size;
	341	}
	342
23d1f36b	343	$column_info->{is_nullable} = $sth->{NULLABLE}->[$i] ? 1 : 0;
	344
	345	if ($column_info->{data_type} =~ m/^(.?)\((.?)\)$/) {
	346	$column_info->{data_type} = $1;
	347	$column_info->{size} = $2;
12af3806	348	}
12af3806	349
45be2ce7	350	my $extra_info = $self->_extra_column_info($table, $columns[$i], $column_info) \|\| {};
23d1f36b	351	$column_info = { %$column_info, %$extra_info };
23d1f36b	352
23d1f36b	353	$result{$columns[$i]} = $column_info;
12af3806	354	}
6ce0bcc3	355	$sth->finish;
	356
	357	foreach my $col (keys %result) {
	358	my $colinfo = $result{$col};
	359	my $type_num = $colinfo->{data_type};
	360	my $type_name;
4145a6f3	361	if(defined $type_num && $type_num =~ /^\d+\z/ && $dbh->can('type_info')) {
6ce0bcc3	362	my $type_info = $dbh->type_info($type_num);
6ce0bcc3	363	$type_name = $type_info->{TYPE_NAME} if $type_info;
cf0ba25b	364	$colinfo->{data_type} = lc $type_name if $type_name;
6ce0bcc3	365	}
6ce0bcc3	366	}
12af3806	367
	368	return \%result;
	369	}
	370
a8df0345	371	# Override this in vendor class to return any additional column
	372	# attributes
	373	sub _extra_column_info {}
c5baf131	374
996be9ee	375	=head1 SEE ALSO
	376
	377	L<DBIx::Class::Schema::Loader>
	378
be80bba7	379	=head1 AUTHOR
be80bba7	380
9cc8e7e1	381	See L<DBIx::Class::Schema::Loader/AUTHOR> and L<DBIx::Class::Schema::Loader/CONTRIBUTORS>.
be80bba7	382
	383	=head1 LICENSE
	384
	385	This library is free software; you can redistribute it and/or modify it under
	386	the same terms as Perl itself.
	387
996be9ee	388	=cut
	389
	390	1;
26334ec1	391	# vim:et sts=4 sw=4 tw=0: