[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 base qw/DBIx::Class::Schema::Loader::DBI/;
use mro 'c3';
use Carp::Clan qw/^DBIx::Class/;
use List::Util 'first';
use namespace::clean;
use DBIx::Class::Schema::Loader::Table ();

our $VERSION = '0.07033';

sub _supports_db_schema { 0 }

=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) {
        $self->preserve_case(0);
    }
    elsif ($self->preserve_case) {
        $self->schema->storage->sql_maker->quote_char('"');
        $self->schema->storage->sql_maker->name_sep('.');
    }

    if ($self->db_schema) {
        carp "db_schema is not supported on Firebird";

        if ($self->db_schema->[0] eq '%') {
            $self->db_schema(undef);
        }
    }
}

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

    my $sth = $self->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->name);

    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, $attrs, @rels);
    my $sth = $self->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->name);

    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} = DBIx::Class::Schema::Loader::Table->new(
            loader => $self,
            name   => $remote_tab,
            ($self->db_schema ? (
                schema        => $self->db_schema->[0],
                ignore_schema => 1,
            ) : ()),
        );
    }

    local $self->dbh->{LongReadLen} = 100_000;
    local $self->dbh->{LongTruncOk} = 1;

    my %RULE_FOR = (
        4 => 'on_update',
        6 => 'on_delete',
    );

    $sth = $self->dbh->prepare_cached(<<'EOF');
select rdb$trigger_blr, rdb$trigger_type
from rdb$triggers
where rdb$trigger_type in (4,6)
    and rdb$system_flag > 0
    and rdb$relation_name = ?
EOF

    foreach my $fk (keys %$remote_table) {
        my $uk_table = $remote_table->{$fk};

        $sth->execute($uk_table);

        while (my ($blr, $type) = $sth->fetchrow_array) {
            $type = $RULE_FOR{$type};

            print STDERR "GOT $type:\n";
            use Data::Dumper;
            print STDERR Dumper($blr), "\n";
        }
    }

    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 $sth = $self->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->name);

    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(@_);

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

    while (my ($column, $info) = each %$result) {
        my $data_type = $info->{data_type};

        my $sth = $self->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->name);

        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 = $self->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->name, $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 ($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 (defined $char_set_id && $char_set_id == 3) {
                        $info->{data_type} = 'blob sub_type text character set unicode_fss';
                    }
                    else {
                        $info->{data_type} = 'blob sub_type text';
                    }
                }
            }
        }

        $data_type = $info->{data_type};

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

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

        $data_type = $info->{data_type};

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

            if (defined $char_set_id && $char_set_id == 3) {
                $info->{data_type} .= '(x) character set unicode_fss';
            }
        }
        elsif ($data_type !~ /^(?:numeric|decimal)\z/) {
            delete $info->{size};
        }

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

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