[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 mro '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.07010';

=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, f.rdb$character_set_id, f.rdb$character_length, 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, $char_set_id, $char_length, $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') {
                    if ($char_set_id == 3) {
                        $info->{data_type} = 'blob sub_type text character set unicode_fss';
                    }
                    else {
                        $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';
        }

        if ($info->{data_type} =~ /^(?:char|varchar)\z/) {
            $info->{size} = $char_length;

            if ($char_set_id == 3) {
                $info->{data_type} .= '(x) character set unicode_fss';
            }
        }
        elsif ($info->{data_type} !~ /^(?: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;
942bd5e0	5	use mro 'c3';
4cbddf8d	6	use base qw/DBIx::Class::Schema::Loader::DBI/;
4cbddf8d	7	use Carp::Clan qw/^DBIx::Class/;
4145a6f3	8	use List::Util 'first';
2b74a06b	9	use namespace::clean;
4cbddf8d	10
4295c4b4	11	our $VERSION = '0.07010';
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
cf0ba25b	194	$sth = $dbh->prepare(<<'EOF');
5111e5d0	195	SELECT f.rdb$field_precision, f.rdb$field_scale, f.rdb$field_type, f.rdb$field_sub_type, f.rdb$character_set_id, f.rdb$character_length, t.rdb$type_name, st.rdb$type_name
cf0ba25b	196	FROM rdb$fields f
cf0ba25b	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));
5111e5d0	204	my ($precision, $scale, $type_num, $sub_type_num, $char_set_id, $char_length, $type_name, $sub_type_name) = $sth->fetchrow_array;
cf0ba25b	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') {
5111e5d0	228	if ($char_set_id == 3) {
	229	$info->{data_type} = 'blob sub_type text character set unicode_fss';
	230	}
	231	else {
	232	$info->{data_type} = 'blob sub_type text';
	233	}
cf0ba25b	234	}
	235	}
	236	}
	237
9dc968df	238	if ($info->{data_type} =~ /^(?:decimal\|numeric)\z/ && defined $precision && defined $scale) {
cf0ba25b	239	if ($precision == 9 && $scale == 0) {
	240	delete $info->{size};
	241	}
	242	else {
	243	$info->{size} = [$precision, $scale];
	244	}
	245	}
	246
	247	if ($info->{data_type} eq '11') {
	248	$info->{data_type} = 'timestamp';
	249	}
	250	elsif ($info->{data_type} eq '10') {
	251	$info->{data_type} = 'time';
	252	}
	253	elsif ($info->{data_type} eq '9') {
	254	$info->{data_type} = 'date';
	255	}
	256	elsif ($info->{data_type} eq 'character varying') {
	257	$info->{data_type} = 'varchar';
	258	}
	259	elsif ($info->{data_type} eq 'character') {
	260	$info->{data_type} = 'char';
	261	}
28d53000	262	elsif ($info->{data_type} eq 'float') {
	263	$info->{data_type} = 'real';
	264	}
cf0ba25b	265	elsif ($info->{data_type} eq 'int64' \|\| $info->{data_type} eq '-9581') {
	266	# the constant is just in case, the query should pick up the type
	267	$info->{data_type} = 'bigint';
	268	}
	269
5111e5d0	270	if ($info->{data_type} =~ /^(?:char\|varchar)\z/) {
	271	$info->{size} = $char_length;
	272
	273	if ($char_set_id == 3) {
	274	$info->{data_type} .= '(x) character set unicode_fss';
	275	}
cf0ba25b	276	}
5111e5d0	277	elsif ($info->{data_type} !~ /^(?:numeric\|decimal)\z/) {
cf0ba25b	278	delete $info->{size};
cf0ba25b	279	}
4145a6f3	280
4145a6f3	281	# get default
cf0ba25b	282	delete $info->{default_value} if $info->{default_value} && $info->{default_value} eq 'NULL';
	283
	284	$sth = $dbh->prepare(<<'EOF');
4145a6f3	285	SELECT rf.rdb$default_source
	286	FROM rdb$relation_fields rf
	287	WHERE rf.rdb$relation_name = ?
	288	AND rf.rdb$field_name = ?
	289	EOF
cf0ba25b	290	$sth->execute($table, $self->_uc($column));
cf0ba25b	291	my ($default_src) = $sth->fetchrow_array;
4145a6f3	292
cf0ba25b	293	if ($default_src && (my ($def) = $default_src =~ /^DEFAULT \s+ (\S+)/ix)) {
	294	if (my ($quoted) = $def =~ /^'(.*?)'\z/) {
	295	$info->{default_value} = $quoted;
	296	}
	297	else {
2a1ff2ee	298	$info->{default_value} = $def =~ /^-?\d/ ? $def : \$def;
cf0ba25b	299	}
4145a6f3	300	}
6e566cc4	301
	302	${ $info->{default_value} } = 'current_timestamp'
	303	if ref $info->{default_value} && ${ $info->{default_value} } eq 'CURRENT_TIMESTAMP';
4145a6f3	304	}
4145a6f3	305
cf0ba25b	306	return $result;
45be2ce7	307	}
45be2ce7	308
4cbddf8d	309	=head1 SEE ALSO
	310
	311	L<DBIx::Class::Schema::Loader>, L<DBIx::Class::Schema::Loader::Base>,
	312	L<DBIx::Class::Schema::Loader::DBI>
	313
	314	=head1 AUTHOR
	315
	316	See L<DBIx::Class::Schema::Loader/AUTHOR> and L<DBIx::Class::Schema::Loader/CONTRIBUTORS>.
	317
	318	=head1 LICENSE
	319
	320	This library is free software; you can redistribute it and/or modify it under
	321	the same terms as Perl itself.
	322
	323	=cut
	324
	325	1;
cf0ba25b	326	# vim:et sw=4 sts=4 tw=0: