[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 namespace::autoclean;
use Class::C3;
use base qw/DBIx::Class::Schema::Loader::DBI/;
use Carp::Clan qw/^DBIx::Class/;
use List::Util 'first';

__PACKAGE__->mk_group_ro_accessors('simple', qw/
    unquoted_ddl
/);

our $VERSION = '0.06000';

=head1 NAME

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

=head1 DESCRIPTION

See L<DBIx::Class::Schema::Loader::Base> for available options.

By default column names from unquoted DDL will be generated in uppercase, as
that is the only way they will work with quoting on.

See the L</unquoted_ddl> option in this driver if you would like to have
lowercase column names.

=head1 DRIVER OPTIONS

=head2 unquoted_ddl

Set this loader option if your DDL uses unquoted identifiers and you will not
use quoting (the L<quote_char|DBIx::Class::Storage::DBI/quote_char> option in
L<connect_info|DBIx::Class::Storage::DBI/connect_info>.)

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 _is_case_sensitive {
    my $self = shift;

    return $self->unquoted_ddl ? 0 : 1;
}

sub _setup {
    my $self = shift;

    $self->next::method;

    $self->schema->storage->sql_maker->name_sep('.');

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

WARNING: Assuming mixed-case Firebird DDL, see the unquoted_ddl option in
perldoc DBIx::Class::Schema::Loader::DBI::InterBase
for more information.

EOF
    }

    if (not $self->unquoted_ddl) {
        $self->schema->storage->sql_maker->quote_char('"');
    }
    else {
        $self->schema->storage->sql_maker->quote_char(undef);
    }
}

sub _lc {
    my ($self, $name) = @_;

    return $self->unquoted_ddl ? lc($name) : $name;
}

sub _uc {
    my ($self, $name) = @_;

    return $self->unquoted_ddl ? uc($name) : $name;
}

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

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

    my @keydata;

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

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

    return \@keydata;
}

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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