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

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 (sort 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);
    }

    return [ map { [ $_ => $constraints->{$_} ] } sort keys %$constraints ];
}

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

sub _view_definition {
    my ($self, $view) = @_;

    return scalar $self->schema->storage->dbh->selectrow_array(<<'EOF', {}, $view->name);
SELECT rdb$view_source
FROM rdb$relations
WHERE rdb$relation_name = ?
EOF
}

=head1 SEE ALSO

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

=head1 AUTHORS

See L<DBIx::Class::Schema::Loader/AUTHORS>.

=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
306bf770	12	our $VERSION = '0.07047';
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
494e0205	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	}
4cbddf8d	123
4825ee09	124	foreach my $fk (sort keys %$remote_table) {
4cbddf8d	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	}
4cbddf8d	152
6c4f5a4a	153	return [ map { [ $_ => $constraints->{$_} ] } sort keys %$constraints ];
4cbddf8d	154	}
4cbddf8d	155
cf0ba25b	156	sub _columns_info_for {
	157	my $self = shift;
	158	my ($table) = @_;
	159
	160	my $result = $self->next::method(@_);
45be2ce7	161
c4a69b87	162	local $self->dbh->{LongReadLen} = 100000;
c4a69b87	163	local $self->dbh->{LongTruncOk} = 1;
45be2ce7	164
cf0ba25b	165	while (my ($column, $info) = each %$result) {
c4a69b87	166	my $data_type = $info->{data_type};
	167
	168	my $sth = $self->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
c4a69b87	175	$sth->execute($table->name);
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
c4a69b87	194	$sth = $self->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
c4a69b87	203	$sth->execute($table->name, $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
c4a69b87	211	if ($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') {
4a01c33f	228	if (defined $char_set_id && $char_set_id == 3) {
5111e5d0	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
c4a69b87	238	$data_type = $info->{data_type};
	239
	240	if ($data_type =~ /^(?:decimal\|numeric)\z/ && defined $precision && defined $scale) {
cf0ba25b	241	if ($precision == 9 && $scale == 0) {
	242	delete $info->{size};
	243	}
	244	else {
	245	$info->{size} = [$precision, $scale];
	246	}
	247	}
	248
c4a69b87	249	if ($data_type eq '11') {
cf0ba25b	250	$info->{data_type} = 'timestamp';
cf0ba25b	251	}
c4a69b87	252	elsif ($data_type eq '10') {
cf0ba25b	253	$info->{data_type} = 'time';
cf0ba25b	254	}
c4a69b87	255	elsif ($data_type eq '9') {
cf0ba25b	256	$info->{data_type} = 'date';
cf0ba25b	257	}
c4a69b87	258	elsif ($data_type eq 'character varying') {
cf0ba25b	259	$info->{data_type} = 'varchar';
cf0ba25b	260	}
c4a69b87	261	elsif ($data_type eq 'character') {
cf0ba25b	262	$info->{data_type} = 'char';
cf0ba25b	263	}
c4a69b87	264	elsif ($data_type eq 'float') {
28d53000	265	$info->{data_type} = 'real';
28d53000	266	}
c4a69b87	267	elsif ($data_type eq 'int64' \|\| $data_type eq '-9581') {
cf0ba25b	268	# the constant is just in case, the query should pick up the type
	269	$info->{data_type} = 'bigint';
	270	}
	271
c4a69b87	272	$data_type = $info->{data_type};
	273
	274	if ($data_type =~ /^(?:char\|varchar)\z/) {
5111e5d0	275	$info->{size} = $char_length;
5111e5d0	276
4a01c33f	277	if (defined $char_set_id && $char_set_id == 3) {
5111e5d0	278	$info->{data_type} .= '(x) character set unicode_fss';
5111e5d0	279	}
cf0ba25b	280	}
c4a69b87	281	elsif ($data_type !~ /^(?:numeric\|decimal)\z/) {
cf0ba25b	282	delete $info->{size};
cf0ba25b	283	}
4145a6f3	284
4145a6f3	285	# get default
cf0ba25b	286	delete $info->{default_value} if $info->{default_value} && $info->{default_value} eq 'NULL';
cf0ba25b	287
c4a69b87	288	$sth = $self->dbh->prepare(<<'EOF');
4145a6f3	289	SELECT rf.rdb$default_source
	290	FROM rdb$relation_fields rf
	291	WHERE rf.rdb$relation_name = ?
	292	AND rf.rdb$field_name = ?
	293	EOF
c4a69b87	294	$sth->execute($table->name, $self->_uc($column));
cf0ba25b	295	my ($default_src) = $sth->fetchrow_array;
4145a6f3	296
cf0ba25b	297	if ($default_src && (my ($def) = $default_src =~ /^DEFAULT \s+ (\S+)/ix)) {
	298	if (my ($quoted) = $def =~ /^'(.*?)'\z/) {
	299	$info->{default_value} = $quoted;
	300	}
	301	else {
2a1ff2ee	302	$info->{default_value} = $def =~ /^-?\d/ ? $def : \$def;
cf0ba25b	303	}
4145a6f3	304	}
6e566cc4	305
	306	${ $info->{default_value} } = 'current_timestamp'
	307	if ref $info->{default_value} && ${ $info->{default_value} } eq 'CURRENT_TIMESTAMP';
4145a6f3	308	}
4145a6f3	309
cf0ba25b	310	return $result;
45be2ce7	311	}
45be2ce7	312
d7e0e0e8	313	sub _view_definition {
	314	my ($self, $view) = @_;
	315
	316	return scalar $self->schema->storage->dbh->selectrow_array(<<'EOF', {}, $view->name);
	317	SELECT rdb$view_source
	318	FROM rdb$relations
	319	WHERE rdb$relation_name = ?
	320	EOF
	321	}
	322
4cbddf8d	323	=head1 SEE ALSO
	324
	325	L<DBIx::Class::Schema::Loader>, L<DBIx::Class::Schema::Loader::Base>,
	326	L<DBIx::Class::Schema::Loader::DBI>
	327
b87ab391	328	=head1 AUTHORS
4cbddf8d	329
b87ab391	330	See L<DBIx::Class::Schema::Loader/AUTHORS>.
4cbddf8d	331
	332	=head1 LICENSE
	333
	334	This library is free software; you can redistribute it and/or modify it under
	335	the same terms as Perl itself.
	336
	337	=cut
	338
	339	1;
cf0ba25b	340	# vim:et sw=4 sts=4 tw=0: