[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.07036_03';

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, @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,
            ) : ()),
        );
    }

    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
02359603	12	our $VERSION = '0.07036_03';
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
b511f36e	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
	96	my ($local_cols, $remote_cols, $remote_table, @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);
18e84656	113	push @{$remote_cols->{$fk}}, $self->_lc($remote_col);
c4a69b87	114	$remote_table->{$fk} = DBIx::Class::Schema::Loader::Table->new(
	115	loader => $self,
	116	name => $remote_tab,
	117	($self->db_schema ? (
	118	schema => $self->db_schema->[0],
	119	ignore_schema => 1,
	120	) : ()),
	121	);
4cbddf8d	122	}
	123
	124	foreach my $fk (keys %$remote_table) {
	125	push @rels, {
	126	local_columns => $local_cols->{$fk},
	127	remote_columns => $remote_cols->{$fk},
	128	remote_table => $remote_table->{$fk},
	129	};
	130	}
	131	return \@rels;
	132	}
	133
	134	sub _table_uniq_info {
	135	my ($self, $table) = @_;
	136
c4a69b87	137	my $sth = $self->dbh->prepare(<<'EOF');
4cbddf8d	138	SELECT rc.rdb$constraint_name, iseg.rdb$field_name
	139	FROM rdb$relation_constraints rc
	140	JOIN rdb$index_segments iseg ON rc.rdb$index_name = iseg.rdb$index_name
	141	WHERE rc.rdb$constraint_type = 'UNIQUE' and rc.rdb$relation_name = ?
	142	ORDER BY iseg.rdb$field_position
	143	EOF
c4a69b87	144	$sth->execute($table->name);
4cbddf8d	145
	146	my $constraints;
	147	while (my ($constraint_name, $column) = $sth->fetchrow_array) {
	148	s/^\s+//, s/\s+\z// for $constraint_name, $column;
	149
18e84656	150	push @{$constraints->{$constraint_name}}, $self->_lc($column);
4cbddf8d	151	}
	152
	153	my @uniqs = map { [ $_ => $constraints->{$_} ] } keys %$constraints;
	154	return \@uniqs;
	155	}
	156
cf0ba25b	157	sub _columns_info_for {
	158	my $self = shift;
	159	my ($table) = @_;
	160
	161	my $result = $self->next::method(@_);
45be2ce7	162
c4a69b87	163	local $self->dbh->{LongReadLen} = 100000;
c4a69b87	164	local $self->dbh->{LongTruncOk} = 1;
45be2ce7	165
cf0ba25b	166	while (my ($column, $info) = each %$result) {
c4a69b87	167	my $data_type = $info->{data_type};
	168
	169	my $sth = $self->dbh->prepare(<<'EOF');
45be2ce7	170	SELECT t.rdb$trigger_source
	171	FROM rdb$triggers t
	172	WHERE t.rdb$relation_name = ?
93e8c513	173	AND t.rdb$system_flag = 0 -- user defined
93e8c513	174	AND t.rdb$trigger_type = 1 -- BEFORE INSERT
45be2ce7	175	EOF
c4a69b87	176	$sth->execute($table->name);
45be2ce7	177
cf0ba25b	178	while (my ($trigger) = $sth->fetchrow_array) {
cf0ba25b	179	my @trig_cols = map { /^"([^"]+)/ ? $1 : uc($_) } $trigger =~ /new\.("?\w+"?)/ig;
243c6ebc	180
cf0ba25b	181	my ($quoted, $generator) = $trigger =~ /(?:gen_id\s* \( \s* \|next \s* value \s* for \s*)(")?(\w+)/ix;
4145a6f3	182
cf0ba25b	183	if ($generator) {
cf0ba25b	184	$generator = uc $generator unless $quoted;
0e0a4941	185
cf0ba25b	186	if (first { $self->_uc($_) eq $self->_uc($column) } @trig_cols) {
	187	$info->{is_auto_increment} = 1;
	188	$info->{sequence} = $generator;
	189	last;
	190	}
0e0a4941	191	}
45be2ce7	192	}
45be2ce7	193
cf0ba25b	194	# fix up types
c4a69b87	195	$sth = $self->dbh->prepare(<<'EOF');
5111e5d0	196	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	197	FROM rdb$fields f
cf0ba25b	198	JOIN rdb$relation_fields rf ON rf.rdb$field_source = f.rdb$field_name
9dc968df	199	LEFT JOIN rdb$types t ON f.rdb$field_type = t.rdb$type AND t.rdb$field_name = 'RDB$FIELD_TYPE'
9dc968df	200	LEFT JOIN rdb$types st ON f.rdb$field_sub_type = st.rdb$type AND st.rdb$field_name = 'RDB$FIELD_SUB_TYPE'
cf0ba25b	201	WHERE rf.rdb$relation_name = ?
	202	AND rf.rdb$field_name = ?
	203	EOF
c4a69b87	204	$sth->execute($table->name, $self->_uc($column));
5111e5d0	205	my ($precision, $scale, $type_num, $sub_type_num, $char_set_id, $char_length, $type_name, $sub_type_name) = $sth->fetchrow_array;
cf0ba25b	206	$scale = -$scale if $scale && $scale < 0;
	207
	208	if ($type_name && $sub_type_name) {
	209	s/\s+\z// for $type_name, $sub_type_name;
	210
	211	# fixups primarily for DBD::InterBase
c4a69b87	212	if ($data_type =~ /^(?:integer\|int\|smallint\|bigint\|-9581)\z/) {
9dc968df	213	if ($precision && $type_name =~ /^(?:LONG\|INT64)\z/ && $sub_type_name eq 'BLR') {
cf0ba25b	214	$info->{data_type} = 'decimal';
cf0ba25b	215	}
9dc968df	216	elsif ($precision && $type_name =~ /^(?:LONG\|SHORT\|INT64)\z/ && $sub_type_name eq 'TEXT') {
cf0ba25b	217	$info->{data_type} = 'numeric';
	218	}
	219	elsif ((not $precision) && $type_name eq 'INT64' && $sub_type_name eq 'BINARY') {
	220	$info->{data_type} = 'bigint';
	221	}
	222	}
	223	# ODBC makes regular blobs sub_type blr
	224	elsif ($type_name eq 'BLOB') {
	225	if ($sub_type_name eq 'BINARY') {
	226	$info->{data_type} = 'blob';
	227	}
	228	elsif ($sub_type_name eq 'TEXT') {
4a01c33f	229	if (defined $char_set_id && $char_set_id == 3) {
5111e5d0	230	$info->{data_type} = 'blob sub_type text character set unicode_fss';
	231	}
	232	else {
	233	$info->{data_type} = 'blob sub_type text';
	234	}
cf0ba25b	235	}
	236	}
	237	}
	238
c4a69b87	239	$data_type = $info->{data_type};
	240
	241	if ($data_type =~ /^(?:decimal\|numeric)\z/ && defined $precision && defined $scale) {
cf0ba25b	242	if ($precision == 9 && $scale == 0) {
	243	delete $info->{size};
	244	}
	245	else {
	246	$info->{size} = [$precision, $scale];
	247	}
	248	}
	249
c4a69b87	250	if ($data_type eq '11') {
cf0ba25b	251	$info->{data_type} = 'timestamp';
cf0ba25b	252	}
c4a69b87	253	elsif ($data_type eq '10') {
cf0ba25b	254	$info->{data_type} = 'time';
cf0ba25b	255	}
c4a69b87	256	elsif ($data_type eq '9') {
cf0ba25b	257	$info->{data_type} = 'date';
cf0ba25b	258	}
c4a69b87	259	elsif ($data_type eq 'character varying') {
cf0ba25b	260	$info->{data_type} = 'varchar';
cf0ba25b	261	}
c4a69b87	262	elsif ($data_type eq 'character') {
cf0ba25b	263	$info->{data_type} = 'char';
cf0ba25b	264	}
c4a69b87	265	elsif ($data_type eq 'float') {
28d53000	266	$info->{data_type} = 'real';
28d53000	267	}
c4a69b87	268	elsif ($data_type eq 'int64' \|\| $data_type eq '-9581') {
cf0ba25b	269	# the constant is just in case, the query should pick up the type
	270	$info->{data_type} = 'bigint';
	271	}
	272
c4a69b87	273	$data_type = $info->{data_type};
	274
	275	if ($data_type =~ /^(?:char\|varchar)\z/) {
5111e5d0	276	$info->{size} = $char_length;
5111e5d0	277
4a01c33f	278	if (defined $char_set_id && $char_set_id == 3) {
5111e5d0	279	$info->{data_type} .= '(x) character set unicode_fss';
5111e5d0	280	}
cf0ba25b	281	}
c4a69b87	282	elsif ($data_type !~ /^(?:numeric\|decimal)\z/) {
cf0ba25b	283	delete $info->{size};
cf0ba25b	284	}
4145a6f3	285
4145a6f3	286	# get default
cf0ba25b	287	delete $info->{default_value} if $info->{default_value} && $info->{default_value} eq 'NULL';
cf0ba25b	288
c4a69b87	289	$sth = $self->dbh->prepare(<<'EOF');
4145a6f3	290	SELECT rf.rdb$default_source
	291	FROM rdb$relation_fields rf
	292	WHERE rf.rdb$relation_name = ?
	293	AND rf.rdb$field_name = ?
	294	EOF
c4a69b87	295	$sth->execute($table->name, $self->_uc($column));
cf0ba25b	296	my ($default_src) = $sth->fetchrow_array;
4145a6f3	297
cf0ba25b	298	if ($default_src && (my ($def) = $default_src =~ /^DEFAULT \s+ (\S+)/ix)) {
	299	if (my ($quoted) = $def =~ /^'(.*?)'\z/) {
	300	$info->{default_value} = $quoted;
	301	}
	302	else {
2a1ff2ee	303	$info->{default_value} = $def =~ /^-?\d/ ? $def : \$def;
cf0ba25b	304	}
4145a6f3	305	}
6e566cc4	306
	307	${ $info->{default_value} } = 'current_timestamp'
	308	if ref $info->{default_value} && ${ $info->{default_value} } eq 'CURRENT_TIMESTAMP';
4145a6f3	309	}
4145a6f3	310
cf0ba25b	311	return $result;
45be2ce7	312	}
45be2ce7	313
4cbddf8d	314	=head1 SEE ALSO
	315
	316	L<DBIx::Class::Schema::Loader>, L<DBIx::Class::Schema::Loader::Base>,
	317	L<DBIx::Class::Schema::Loader::DBI>
	318
	319	=head1 AUTHOR
	320
	321	See L<DBIx::Class::Schema::Loader/AUTHOR> and L<DBIx::Class::Schema::Loader/CONTRIBUTORS>.
	322
	323	=head1 LICENSE
	324
	325	This library is free software; you can redistribute it and/or modify it under
	326	the same terms as Perl itself.
	327
	328	=cut
	329
	330	1;
cf0ba25b	331	# vim:et sw=4 sts=4 tw=0: