[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 mro 'c3';
use Carp::Clan qw/^DBIx::Class/;
use Try::Tiny;
use namespace::clean;

our $VERSION = '0.07007';

__PACKAGE__->mk_group_accessors('simple', qw/
    _disable_pk_detection
    _disable_uniq_detection
    _disable_fk_detection
    _passwords
/);

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

    LOOP: for my $table (@tables) {
        try {
            my $sth = $self->_sth_for($table, undef, \'1 = 0');
            $sth->execute;
        }
        catch {
            warn "Bad table or view '$table', ignoring: $_\n";
            $self->_unregister_source_for_table($table);
            no warnings 'exiting';
            next LOOP;
        };

        push @filtered_tables, $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) = @_;

    return [] if $self->_disable_pk_detection;

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

    my @primary = try {
        $dbh->primary_key('', $self->db_schema, $table);
    }
    catch {
        warn "Cannot find primary keys for this driver: $_";
        $self->_disable_pk_detection(1);
        return ();
    };

    return [] if not @primary;

    @primary = map { $self->_lc($_) } @primary;
    s/\Q$self->{_quoter}\E//g for @primary;

    return \@primary;
}

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

    return [] if $self->_disable_uniq_detection;

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

    if (not $dbh->can('statistics_info')) {
        warn "No UNIQUE constraint information can be gathered for this driver";
        $self->_disable_uniq_detection(1);
        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}] = $self->_lc($row->{COLUMN_NAME});
    }
    $sth->finish;

    my @retval;
    foreach my $index_name (keys %indices) {
        my $index = $indices{$index_name};
        push(@retval, [ $index_name => [ @$index[1..$#$index] ] ]);
    }

    return \@retval;
}

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

    return [] if $self->_disable_fk_detection;

    my $dbh = $self->schema->storage->dbh;
    my $sth = try {
        $dbh->foreign_key_info( '', $self->db_schema, '',
                                '', $self->db_schema, $table );
    }
    catch {
        warn "Cannot introspect relationships for this driver: $_";
        $self->_disable_fk_detection(1);
        return undef;
    };

    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  = $self->_lc($raw_rel->[3]);
        my $fk_col  = $self->_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;

    my %result;

    if ($dbh->can('column_info')) {
        my $sth = $self->_dbh_column_info($dbh, 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/;

            $col_name = $self->_lc($col_name);

            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 %result;
    }

    my $sth = $self->_sth_for($table, undef, \'1 = 0');
    $sth->execute;

    my @columns = @{ $sth->{NAME} };

    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{ $self->_lc($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;
}

# do not use this, override _columns_info_for instead
sub _extra_column_info {}

# override to mask warnings if needed (see mysql)
sub _dbh_column_info {
    my ($self, $dbh) = (shift, shift);

    return $dbh->column_info(@_);
}

# If a coderef uses DBI->connect, this should get its connect info.
sub _try_infer_connect_info_from_coderef {
    my ($self, $code) = @_;

    my ($dsn, $user, $pass, $params);

    no warnings 'redefine';

    local *DBI::connect = sub {
        (undef, $dsn, $user, $pass, $params) = @_;
    };

    $code->();

    return ($dsn, $user, $pass, $params);
}

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