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

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

use strict;
use warnings;
use Class::C3;
use base qw/DBIx::Class::Schema::Loader::DBI/;
use Carp::Clan qw/^DBIx::Class/;
use List::Util 'first';
use namespace::clean;

our $VERSION = '0.07001';

=head1 NAME

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

=head1 DESCRIPTION

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

=head1 COLUMN NAME CASE ISSUES

By default column names from unquoted DDL will be generated in lowercase, for
consistency with other backends. 

Set the L<preserve_case|DBIx::Class::Schema::Loader::Base/preserve_case> option
to true if you would like to have column names in the internal case, which is
uppercase for DDL that uses unquoted identifiers.

Do not use quoting (the L<quote_char|DBIx::Class::Storage::DBI/quote_char>
option in L<connect_info|DBIx::Class::Storage::DBI/connect_info> when in the
default C<< preserve_case => 0 >> mode.

Be careful to also not use any SQL reserved words in your DDL.

This will generate lowercase column names (as opposed to the actual uppercase
names) in your Result classes that will only work with quoting off.

Mixed-case table and column names will be ignored when this option is on and
will not work with quoting turned off.

=cut

sub _setup {
    my $self = shift;

    $self->next::method(@_);

    if (not defined $self->preserve_case) {
        warn <<'EOF';

WARNING: Assuming unquoted Firebird DDL, see
perldoc DBIx::Class::Schema::Loader::DBI::InterBase
and the 'preserve_case' option in
perldoc DBIx::Class::Schema::Loader::Base
for more information.

EOF
        $self->preserve_case(0);
    }

    if ($self->preserve_case) {
        $self->schema->storage->sql_maker->quote_char('"');
        $self->schema->storage->sql_maker->name_sep('.');
    }
    else {
        $self->schema->storage->sql_maker->quote_char(undef);
        $self->schema->storage->sql_maker->name_sep(undef);
    }
}

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

    my $dbh = $self->schema->storage->dbh;
    my $sth = $dbh->prepare(<<'EOF');
SELECT iseg.rdb$field_name
FROM rdb$relation_constraints rc
JOIN rdb$index_segments iseg ON rc.rdb$index_name = iseg.rdb$index_name
WHERE rc.rdb$constraint_type = 'PRIMARY KEY' and rc.rdb$relation_name = ?
ORDER BY iseg.rdb$field_position
EOF
    $sth->execute($table);

    my @keydata;

    while (my ($col) = $sth->fetchrow_array) {
        s/^\s+//, s/\s+\z// for $col;

        push @keydata, $self->_lc($col);
    }

    return \@keydata;
}

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

    my ($local_cols, $remote_cols, $remote_table, @rels);
    my $dbh = $self->schema->storage->dbh;
    my $sth = $dbh->prepare(<<'EOF');
SELECT rc.rdb$constraint_name fk, iseg.rdb$field_name local_col, ri.rdb$relation_name remote_tab, riseg.rdb$field_name remote_col
FROM rdb$relation_constraints rc
JOIN rdb$index_segments iseg ON rc.rdb$index_name = iseg.rdb$index_name
JOIN rdb$indices li ON rc.rdb$index_name = li.rdb$index_name
JOIN rdb$indices ri ON li.rdb$foreign_key = ri.rdb$index_name
JOIN rdb$index_segments riseg ON iseg.rdb$field_position = riseg.rdb$field_position and ri.rdb$index_name = riseg.rdb$index_name
WHERE rc.rdb$constraint_type = 'FOREIGN KEY' and rc.rdb$relation_name = ?
ORDER BY iseg.rdb$field_position
EOF
    $sth->execute($table);

    while (my ($fk, $local_col, $remote_tab, $remote_col) = $sth->fetchrow_array) {
        s/^\s+//, s/\s+\z// for $fk, $local_col, $remote_tab, $remote_col;

        push @{$local_cols->{$fk}},  $self->_lc($local_col);
        push @{$remote_cols->{$fk}}, $self->_lc($remote_col);
        $remote_table->{$fk} = $remote_tab;
    }

    foreach my $fk (keys %$remote_table) {
        push @rels, {
            local_columns => $local_cols->{$fk},
            remote_columns => $remote_cols->{$fk},
            remote_table => $remote_table->{$fk},
        };
    }
    return \@rels;
}

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

    my $dbh = $self->schema->storage->dbh;
    my $sth = $dbh->prepare(<<'EOF');
SELECT rc.rdb$constraint_name, iseg.rdb$field_name
FROM rdb$relation_constraints rc
JOIN rdb$index_segments iseg ON rc.rdb$index_name = iseg.rdb$index_name
WHERE rc.rdb$constraint_type = 'UNIQUE' and rc.rdb$relation_name = ?
ORDER BY iseg.rdb$field_position
EOF
    $sth->execute($table);

    my $constraints;
    while (my ($constraint_name, $column) = $sth->fetchrow_array) {
        s/^\s+//, s/\s+\z// for $constraint_name, $column;

        push @{$constraints->{$constraint_name}}, $self->_lc($column);
    }

    my @uniqs = map { [ $_ => $constraints->{$_} ] } keys %$constraints;
    return \@uniqs;
}

sub _columns_info_for {
    my $self = shift;
    my ($table) = @_;

    my $result = $self->next::method(@_);

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

    local $dbh->{LongReadLen} = 100000;
    local $dbh->{LongTruncOk} = 1;

    while (my ($column, $info) = each %$result) {
        my $sth = $dbh->prepare(<<'EOF');
SELECT t.rdb$trigger_source
FROM rdb$triggers t
WHERE t.rdb$relation_name = ?
AND t.rdb$system_flag = 0 -- user defined
AND t.rdb$trigger_type = 1 -- BEFORE INSERT
EOF
        $sth->execute($table);

        while (my ($trigger) = $sth->fetchrow_array) {
            my @trig_cols = map { /^"([^"]+)/ ? $1 : uc($_) } $trigger =~ /new\.("?\w+"?)/ig;

            my ($quoted, $generator) = $trigger =~ /(?:gen_id\s* \( \s* |next \s* value \s* for \s*)(")?(\w+)/ix;

            if ($generator) {
                $generator = uc $generator unless $quoted;

                if (first { $self->_uc($_) eq $self->_uc($column) } @trig_cols) {
                    $info->{is_auto_increment} = 1;
                    $info->{sequence}          = $generator;
                    last;
                }
            }
        }

# fix up types
        $sth = $dbh->prepare(<<'EOF');
SELECT f.rdb$field_precision, f.rdb$field_scale, f.rdb$field_type, f.rdb$field_sub_type, t.rdb$type_name, st.rdb$type_name
FROM rdb$fields f
JOIN rdb$relation_fields rf ON rf.rdb$field_source = f.rdb$field_name
LEFT JOIN rdb$types t  ON f.rdb$field_type     = t.rdb$type  AND t.rdb$field_name  = 'RDB$FIELD_TYPE'
LEFT JOIN rdb$types st ON f.rdb$field_sub_type = st.rdb$type AND st.rdb$field_name = 'RDB$FIELD_SUB_TYPE'
WHERE rf.rdb$relation_name = ?
    AND rf.rdb$field_name  = ?
EOF
        $sth->execute($table, $self->_uc($column));
        my ($precision, $scale, $type_num, $sub_type_num, $type_name, $sub_type_name) = $sth->fetchrow_array;
        $scale = -$scale if $scale && $scale < 0;

        if ($type_name && $sub_type_name) {
            s/\s+\z// for $type_name, $sub_type_name;

            # fixups primarily for DBD::InterBase
            if ($info->{data_type} =~ /^(?:integer|int|smallint|bigint|-9581)\z/) {
                if ($precision && $type_name =~ /^(?:LONG|INT64)\z/ && $sub_type_name eq 'BLR') {
                    $info->{data_type} = 'decimal';
                }
                elsif ($precision && $type_name =~ /^(?:LONG|SHORT|INT64)\z/ && $sub_type_name eq 'TEXT') {
                    $info->{data_type} = 'numeric';
                }
                elsif ((not $precision) && $type_name eq 'INT64' && $sub_type_name eq 'BINARY') {
                    $info->{data_type} = 'bigint';
                }
            }
            # ODBC makes regular blobs sub_type blr
            elsif ($type_name eq 'BLOB') {
                if ($sub_type_name eq 'BINARY') {
                    $info->{data_type} = 'blob';
                }
                elsif ($sub_type_name eq 'TEXT') {
                    $info->{data_type} = 'blob sub_type text';
                }
            }
        }

        if ($info->{data_type} =~ /^(?:decimal|numeric)\z/ && defined $precision && defined $scale) {
            if ($precision == 9 && $scale == 0) {
                delete $info->{size};
            }
            else {
                $info->{size} = [$precision, $scale];
            }
        }

        if ($info->{data_type} eq '11') {
            $info->{data_type} = 'timestamp';
        }
        elsif ($info->{data_type} eq '10') {
            $info->{data_type} = 'time';
        }
        elsif ($info->{data_type} eq '9') {
            $info->{data_type} = 'date';
        }
        elsif ($info->{data_type} eq 'character varying') {
            $info->{data_type} = 'varchar';
        }
        elsif ($info->{data_type} eq 'character') {
            $info->{data_type} = 'char';
        }
        elsif ($info->{data_type} eq 'float') {
            $info->{data_type} = 'real';
        }
        elsif ($info->{data_type} eq 'int64' || $info->{data_type} eq '-9581') {
            # the constant is just in case, the query should pick up the type
            $info->{data_type} = 'bigint';
        }

        # DBD::InterBase sets scale to '0' for some reason for char types
        if ($info->{data_type} =~ /^(?:char|varchar)\z/ && ref($info->{size}) eq 'ARRAY') {
            $info->{size} = $info->{size}[0];
        }
        elsif ($info->{data_type} !~ /^(?:char|varchar|numeric|decimal)\z/) {
            delete $info->{size};
        }

# get default
        delete $info->{default_value} if $info->{default_value} && $info->{default_value} eq 'NULL';

        $sth = $dbh->prepare(<<'EOF');
SELECT rf.rdb$default_source
FROM rdb$relation_fields rf
WHERE rf.rdb$relation_name = ?
AND rf.rdb$field_name = ?
EOF
        $sth->execute($table, $self->_uc($column));
        my ($default_src) = $sth->fetchrow_array;

        if ($default_src && (my ($def) = $default_src =~ /^DEFAULT \s+ (\S+)/ix)) {
            if (my ($quoted) = $def =~ /^'(.*?)'\z/) {
                $info->{default_value} = $quoted;
            }
            else {
                $info->{default_value} = $def =~ /^-?\d/ ? $def : \$def;
            }
        }

        ${ $info->{default_value} } = 'current_timestamp'
            if ref $info->{default_value} && ${ $info->{default_value} } eq 'CURRENT_TIMESTAMP';
    }

    return $result;
}

=head1 SEE ALSO

L<DBIx::Class::Schema::Loader>, L<DBIx::Class::Schema::Loader::Base>,
L<DBIx::Class::Schema::Loader::DBI>

=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 sw=4 sts=4 tw=0:
Commit	Line	Data
4cbddf8d	1	package DBIx::Class::Schema::Loader::DBI::InterBase;
	2
	3	use strict;
	4	use warnings;
4cbddf8d	5	use Class::C3;
	6	use base qw/DBIx::Class::Schema::Loader::DBI/;
	7	use Carp::Clan qw/^DBIx::Class/;
4145a6f3	8	use List::Util 'first';
2b74a06b	9	use namespace::clean;
4cbddf8d	10
6b1d4f76	11	our $VERSION = '0.07001';
4cbddf8d	12
	13	=head1 NAME
	14
	15	DBIx::Class::Schema::Loader::DBI::InterBase - DBIx::Class::Schema::Loader::DBI
	16	Firebird Implementation.
	17
	18	=head1 DESCRIPTION
	19
bc1cb85e	20	See L<DBIx::Class::Schema::Loader> and L<DBIx::Class::Schema::Loader::Base>.
	21
	22	=head1 COLUMN NAME CASE ISSUES
4cbddf8d	23
b511f36e	24	By default column names from unquoted DDL will be generated in lowercase, for
b511f36e	25	consistency with other backends.
18e84656	26
b511f36e	27	Set the L<preserve_case\|DBIx::Class::Schema::Loader::Base/preserve_case> option
	28	to true if you would like to have column names in the internal case, which is
	29	uppercase for DDL that uses unquoted identifiers.
18e84656	30
b511f36e	31	Do not use quoting (the L<quote_char\|DBIx::Class::Storage::DBI/quote_char>
	32	option in L<connect_info\|DBIx::Class::Storage::DBI/connect_info> when in the
	33	default C<< preserve_case => 0 >> mode.
18e84656	34
bc1cb85e	35	Be careful to also not use any SQL reserved words in your DDL.
bc1cb85e	36
18e84656	37	This will generate lowercase column names (as opposed to the actual uppercase
	38	names) in your Result classes that will only work with quoting off.
	39
	40	Mixed-case table and column names will be ignored when this option is on and
	41	will not work with quoting turned off.
	42
bc1cb85e	43	=cut
243c6ebc	44
ffb03c96	45	sub _setup {
	46	my $self = shift;
	47
bc1cb85e	48	$self->next::method(@_);
18e84656	49
bc1cb85e	50	if (not defined $self->preserve_case) {
ec957051	51	warn <<'EOF';
ec957051	52
b511f36e	53	WARNING: Assuming unquoted Firebird DDL, see
ec957051	54	perldoc DBIx::Class::Schema::Loader::DBI::InterBase
bc1cb85e	55	and the 'preserve_case' option in
bc1cb85e	56	perldoc DBIx::Class::Schema::Loader::Base
ec957051	57	for more information.
	58
	59	EOF
b511f36e	60	$self->preserve_case(0);
ec957051	61	}
ec957051	62
bc1cb85e	63	if ($self->preserve_case) {
18e84656	64	$self->schema->storage->sql_maker->quote_char('"');
c930f78b	65	$self->schema->storage->sql_maker->name_sep('.');
18e84656	66	}
	67	else {
	68	$self->schema->storage->sql_maker->quote_char(undef);
c930f78b	69	$self->schema->storage->sql_maker->name_sep(undef);
18e84656	70	}
	71	}
	72
4cbddf8d	73	sub _table_pk_info {
	74	my ($self, $table) = @_;
	75
	76	my $dbh = $self->schema->storage->dbh;
	77	my $sth = $dbh->prepare(<<'EOF');
	78	SELECT iseg.rdb$field_name
	79	FROM rdb$relation_constraints rc
	80	JOIN rdb$index_segments iseg ON rc.rdb$index_name = iseg.rdb$index_name
	81	WHERE rc.rdb$constraint_type = 'PRIMARY KEY' and rc.rdb$relation_name = ?
	82	ORDER BY iseg.rdb$field_position
	83	EOF
	84	$sth->execute($table);
	85
	86	my @keydata;
	87
	88	while (my ($col) = $sth->fetchrow_array) {
	89	s/^\s+//, s/\s+\z// for $col;
	90
18e84656	91	push @keydata, $self->_lc($col);
4cbddf8d	92	}
	93
	94	return \@keydata;
	95	}
	96
	97	sub _table_fk_info {
	98	my ($self, $table) = @_;
	99
	100	my ($local_cols, $remote_cols, $remote_table, @rels);
	101	my $dbh = $self->schema->storage->dbh;
	102	my $sth = $dbh->prepare(<<'EOF');
	103	SELECT rc.rdb$constraint_name fk, iseg.rdb$field_name local_col, ri.rdb$relation_name remote_tab, riseg.rdb$field_name remote_col
	104	FROM rdb$relation_constraints rc
	105	JOIN rdb$index_segments iseg ON rc.rdb$index_name = iseg.rdb$index_name
	106	JOIN rdb$indices li ON rc.rdb$index_name = li.rdb$index_name
	107	JOIN rdb$indices ri ON li.rdb$foreign_key = ri.rdb$index_name
	108	JOIN rdb$index_segments riseg ON iseg.rdb$field_position = riseg.rdb$field_position and ri.rdb$index_name = riseg.rdb$index_name
	109	WHERE rc.rdb$constraint_type = 'FOREIGN KEY' and rc.rdb$relation_name = ?
	110	ORDER BY iseg.rdb$field_position
	111	EOF
	112	$sth->execute($table);
	113
	114	while (my ($fk, $local_col, $remote_tab, $remote_col) = $sth->fetchrow_array) {
	115	s/^\s+//, s/\s+\z// for $fk, $local_col, $remote_tab, $remote_col;
	116
18e84656	117	push @{$local_cols->{$fk}}, $self->_lc($local_col);
18e84656	118	push @{$remote_cols->{$fk}}, $self->_lc($remote_col);
4cbddf8d	119	$remote_table->{$fk} = $remote_tab;
	120	}
	121
	122	foreach my $fk (keys %$remote_table) {
	123	push @rels, {
	124	local_columns => $local_cols->{$fk},
	125	remote_columns => $remote_cols->{$fk},
	126	remote_table => $remote_table->{$fk},
	127	};
	128	}
	129	return \@rels;
	130	}
	131
	132	sub _table_uniq_info {
	133	my ($self, $table) = @_;
	134
	135	my $dbh = $self->schema->storage->dbh;
	136	my $sth = $dbh->prepare(<<'EOF');
	137	SELECT rc.rdb$constraint_name, iseg.rdb$field_name
	138	FROM rdb$relation_constraints rc
	139	JOIN rdb$index_segments iseg ON rc.rdb$index_name = iseg.rdb$index_name
	140	WHERE rc.rdb$constraint_type = 'UNIQUE' and rc.rdb$relation_name = ?
	141	ORDER BY iseg.rdb$field_position
	142	EOF
	143	$sth->execute($table);
	144
	145	my $constraints;
	146	while (my ($constraint_name, $column) = $sth->fetchrow_array) {
	147	s/^\s+//, s/\s+\z// for $constraint_name, $column;
	148
18e84656	149	push @{$constraints->{$constraint_name}}, $self->_lc($column);
4cbddf8d	150	}
	151
	152	my @uniqs = map { [ $_ => $constraints->{$_} ] } keys %$constraints;
	153	return \@uniqs;
	154	}
	155
cf0ba25b	156	sub _columns_info_for {
	157	my $self = shift;
	158	my ($table) = @_;
	159
	160	my $result = $self->next::method(@_);
45be2ce7	161
	162	my $dbh = $self->schema->storage->dbh;
	163
	164	local $dbh->{LongReadLen} = 100000;
	165	local $dbh->{LongTruncOk} = 1;
	166
cf0ba25b	167	while (my ($column, $info) = each %$result) {
cf0ba25b	168	my $sth = $dbh->prepare(<<'EOF');
45be2ce7	169	SELECT t.rdb$trigger_source
	170	FROM rdb$triggers t
	171	WHERE t.rdb$relation_name = ?
93e8c513	172	AND t.rdb$system_flag = 0 -- user defined
93e8c513	173	AND t.rdb$trigger_type = 1 -- BEFORE INSERT
45be2ce7	174	EOF
cf0ba25b	175	$sth->execute($table);
45be2ce7	176
cf0ba25b	177	while (my ($trigger) = $sth->fetchrow_array) {
cf0ba25b	178	my @trig_cols = map { /^"([^"]+)/ ? $1 : uc($_) } $trigger =~ /new\.("?\w+"?)/ig;
243c6ebc	179
cf0ba25b	180	my ($quoted, $generator) = $trigger =~ /(?:gen_id\s* \( \s* \|next \s* value \s* for \s*)(")?(\w+)/ix;
4145a6f3	181
cf0ba25b	182	if ($generator) {
cf0ba25b	183	$generator = uc $generator unless $quoted;
0e0a4941	184
cf0ba25b	185	if (first { $self->_uc($_) eq $self->_uc($column) } @trig_cols) {
	186	$info->{is_auto_increment} = 1;
	187	$info->{sequence} = $generator;
	188	last;
	189	}
0e0a4941	190	}
45be2ce7	191	}
45be2ce7	192
cf0ba25b	193	# fix up types
	194	$sth = $dbh->prepare(<<'EOF');
	195	SELECT f.rdb$field_precision, f.rdb$field_scale, f.rdb$field_type, f.rdb$field_sub_type, t.rdb$type_name, st.rdb$type_name
	196	FROM rdb$fields f
	197	JOIN rdb$relation_fields rf ON rf.rdb$field_source = f.rdb$field_name
9dc968df	198	LEFT JOIN rdb$types t ON f.rdb$field_type = t.rdb$type AND t.rdb$field_name = 'RDB$FIELD_TYPE'
9dc968df	199	LEFT JOIN rdb$types st ON f.rdb$field_sub_type = st.rdb$type AND st.rdb$field_name = 'RDB$FIELD_SUB_TYPE'
cf0ba25b	200	WHERE rf.rdb$relation_name = ?
	201	AND rf.rdb$field_name = ?
	202	EOF
	203	$sth->execute($table, $self->_uc($column));
	204	my ($precision, $scale, $type_num, $sub_type_num, $type_name, $sub_type_name) = $sth->fetchrow_array;
	205	$scale = -$scale if $scale && $scale < 0;
	206
	207	if ($type_name && $sub_type_name) {
	208	s/\s+\z// for $type_name, $sub_type_name;
	209
	210	# fixups primarily for DBD::InterBase
9dc968df	211	if ($info->{data_type} =~ /^(?:integer\|int\|smallint\|bigint\|-9581)\z/) {
9dc968df	212	if ($precision && $type_name =~ /^(?:LONG\|INT64)\z/ && $sub_type_name eq 'BLR') {
cf0ba25b	213	$info->{data_type} = 'decimal';
cf0ba25b	214	}
9dc968df	215	elsif ($precision && $type_name =~ /^(?:LONG\|SHORT\|INT64)\z/ && $sub_type_name eq 'TEXT') {
cf0ba25b	216	$info->{data_type} = 'numeric';
	217	}
	218	elsif ((not $precision) && $type_name eq 'INT64' && $sub_type_name eq 'BINARY') {
	219	$info->{data_type} = 'bigint';
	220	}
	221	}
	222	# ODBC makes regular blobs sub_type blr
	223	elsif ($type_name eq 'BLOB') {
	224	if ($sub_type_name eq 'BINARY') {
	225	$info->{data_type} = 'blob';
	226	}
	227	elsif ($sub_type_name eq 'TEXT') {
	228	$info->{data_type} = 'blob sub_type text';
	229	}
	230	}
	231	}
	232
9dc968df	233	if ($info->{data_type} =~ /^(?:decimal\|numeric)\z/ && defined $precision && defined $scale) {
cf0ba25b	234	if ($precision == 9 && $scale == 0) {
	235	delete $info->{size};
	236	}
	237	else {
	238	$info->{size} = [$precision, $scale];
	239	}
	240	}
	241
	242	if ($info->{data_type} eq '11') {
	243	$info->{data_type} = 'timestamp';
	244	}
	245	elsif ($info->{data_type} eq '10') {
	246	$info->{data_type} = 'time';
	247	}
	248	elsif ($info->{data_type} eq '9') {
	249	$info->{data_type} = 'date';
	250	}
	251	elsif ($info->{data_type} eq 'character varying') {
	252	$info->{data_type} = 'varchar';
	253	}
	254	elsif ($info->{data_type} eq 'character') {
	255	$info->{data_type} = 'char';
	256	}
28d53000	257	elsif ($info->{data_type} eq 'float') {
	258	$info->{data_type} = 'real';
	259	}
cf0ba25b	260	elsif ($info->{data_type} eq 'int64' \|\| $info->{data_type} eq '-9581') {
	261	# the constant is just in case, the query should pick up the type
	262	$info->{data_type} = 'bigint';
	263	}
	264
	265	# DBD::InterBase sets scale to '0' for some reason for char types
9dc968df	266	if ($info->{data_type} =~ /^(?:char\|varchar)\z/ && ref($info->{size}) eq 'ARRAY') {
cf0ba25b	267	$info->{size} = $info->{size}[0];
cf0ba25b	268	}
9dc968df	269	elsif ($info->{data_type} !~ /^(?:char\|varchar\|numeric\|decimal)\z/) {
cf0ba25b	270	delete $info->{size};
cf0ba25b	271	}
4145a6f3	272
4145a6f3	273	# get default
cf0ba25b	274	delete $info->{default_value} if $info->{default_value} && $info->{default_value} eq 'NULL';
	275
	276	$sth = $dbh->prepare(<<'EOF');
4145a6f3	277	SELECT rf.rdb$default_source
	278	FROM rdb$relation_fields rf
	279	WHERE rf.rdb$relation_name = ?
	280	AND rf.rdb$field_name = ?
	281	EOF
cf0ba25b	282	$sth->execute($table, $self->_uc($column));
cf0ba25b	283	my ($default_src) = $sth->fetchrow_array;
4145a6f3	284
cf0ba25b	285	if ($default_src && (my ($def) = $default_src =~ /^DEFAULT \s+ (\S+)/ix)) {
	286	if (my ($quoted) = $def =~ /^'(.*?)'\z/) {
	287	$info->{default_value} = $quoted;
	288	}
	289	else {
2a1ff2ee	290	$info->{default_value} = $def =~ /^-?\d/ ? $def : \$def;
cf0ba25b	291	}
4145a6f3	292	}
6e566cc4	293
	294	${ $info->{default_value} } = 'current_timestamp'
	295	if ref $info->{default_value} && ${ $info->{default_value} } eq 'CURRENT_TIMESTAMP';
4145a6f3	296	}
4145a6f3	297
cf0ba25b	298	return $result;
45be2ce7	299	}
45be2ce7	300
4cbddf8d	301	=head1 SEE ALSO
	302
	303	L<DBIx::Class::Schema::Loader>, L<DBIx::Class::Schema::Loader::Base>,
	304	L<DBIx::Class::Schema::Loader::DBI>
	305
	306	=head1 AUTHOR
	307
	308	See L<DBIx::Class::Schema::Loader/AUTHOR> and L<DBIx::Class::Schema::Loader/CONTRIBUTORS>.
	309
	310	=head1 LICENSE
	311
	312	This library is free software; you can redistribute it and/or modify it under
	313	the same terms as Perl itself.
	314
	315	=cut
	316
	317	1;
cf0ba25b	318	# vim:et sw=4 sts=4 tw=0: