From: Rafael Kitover Date: Sun, 4 Apr 2010 11:53:01 +0000 (-0400) Subject: better Firebird type info X-Git-Tag: 0.06000~6 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=cf0ba25bdf3a501f693f9ff8498f43a98a06991f;p=dbsrgits%2FDBIx-Class-Schema-Loader.git better Firebird type info --- diff --git a/Changes b/Changes index f6df857..96307d1 100644 --- a/Changes +++ b/Changes @@ -21,7 +21,7 @@ Revision history for Perl extension DBIx::Class::Schema::Loader - added config_file option for loading loader options from a file - set inflate_datetime => 1 for 'AS getdate()' computed columns in Sybase - - preliminary Firebird support + - Firebird support - use introspection pragmas instead of regexes to introspect SQLite (hobbs) - generate POD for refs correctly from column_info diff --git a/lib/DBIx/Class/Schema/Loader/DBI.pm b/lib/DBIx/Class/Schema/Loader/DBI.pm index feacaa8..828a347 100644 --- a/lib/DBIx/Class/Schema/Loader/DBI.pm +++ b/lib/DBIx/Class/Schema/Loader/DBI.pm @@ -361,7 +361,7 @@ sub _columns_info_for { if(defined $type_num && $type_num =~ /^\d+\z/ && $dbh->can('type_info')) { my $type_info = $dbh->type_info($type_num); $type_name = $type_info->{TYPE_NAME} if $type_info; - $colinfo->{data_type} = $type_name if $type_name; + $colinfo->{data_type} = lc $type_name if $type_name; } } diff --git a/lib/DBIx/Class/Schema/Loader/DBI/InterBase.pm b/lib/DBIx/Class/Schema/Loader/DBI/InterBase.pm index bcd9ad2..3fdf44c 100644 --- a/lib/DBIx/Class/Schema/Loader/DBI/InterBase.pm +++ b/lib/DBIx/Class/Schema/Loader/DBI/InterBase.pm @@ -171,71 +171,146 @@ EOF return \@uniqs; } -sub _extra_column_info { - my ($self, $table, $column, $info, $dbi_info) = @_; - my %extra_info; +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; - my $sth = $dbh->prepare(<<'EOF'); + 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); + $sth->execute($table); - while (my ($trigger) = $sth->fetchrow_array) { - my @trig_cols = map { - /^"([^"]+)/ ? $1 : uc($1) - } $trigger =~ /new\.("?\w+"?)/ig; + 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; + my ($quoted, $generator) = $trigger =~ /(?:gen_id\s* \( \s* |next \s* value \s* for \s*)(")?(\w+)/ix; - if ($generator) { - $generator = uc $generator unless $quoted; + if ($generator) { + $generator = uc $generator unless $quoted; - if (first { $self->_uc($_) eq $self->_uc($column) } @trig_cols) { - $extra_info{is_auto_increment} = 1; - $extra_info{sequence} = $generator; - last; + if (first { $self->_uc($_) eq $self->_uc($column) } @trig_cols) { + $info->{is_auto_increment} = 1; + $info->{sequence} = $generator; + last; + } } } - } -# fix up DT types, no idea which other types are fucked - if ($info->{data_type} eq '11') { - $extra_info{data_type} = 'TIMESTAMP'; - } - elsif ($info->{data_type} eq '9') { - $extra_info{data_type} = 'DATE'; - } +# 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 - $sth = $dbh->prepare(<<'EOF'); + 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; + $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/) { - $extra_info{default_value} = $quoted; - } - else { - $extra_info{default_value} = $def =~ /^\d/ ? $def : \$def; + 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 \%extra_info; + return $result; } =head1 SEE ALSO @@ -255,3 +330,4 @@ the same terms as Perl itself. =cut 1; +# vim:et sw=4 sts=4 tw=0: diff --git a/t/18firebird_common.t b/t/18firebird_common.t index 9d71c1c..49bf67f 100644 --- a/t/18firebird_common.t +++ b/t/18firebird_common.t @@ -54,6 +54,54 @@ my $tester = dbixcsl_common_tests->new( password => $odbc_password, } : ()), ], + data_types => { + # based on the Interbase Data Definition Guide + # http://www.ibphoenix.com/downloads/60DataDef.zip + # + # Numeric types + 'smallint' => { data_type => 'smallint' }, + 'int' => { data_type => 'integer' }, + 'integer' => { data_type => 'integer' }, + 'bigint' => { data_type => 'bigint' }, + 'float' => { data_type => 'float' }, + 'double precision' => + { data_type => 'double precision' }, + 'real' => { data_type => 'float' }, + + 'float(2)' => { data_type => 'float' }, + 'float(7)' => { data_type => 'float' }, + 'float(8)' => { data_type => 'double precision' }, + + 'decimal' => { data_type => 'decimal' }, + 'dec' => { data_type => 'decimal' }, + 'numeric' => { data_type => 'numeric' }, + + 'decimal(3)' => { data_type => 'decimal', size => [3,0] }, + + 'decimal(3,3)' => { data_type => 'decimal', size => [3,3] }, + 'dec(3,3)' => { data_type => 'decimal', size => [3,3] }, + 'numeric(3,3)' => { data_type => 'numeric', size => [3,3] }, + + 'decimal(18,18)' => { data_type => 'decimal', size => [18,18] }, + 'dec(18,18)' => { data_type => 'decimal', size => [18,18] }, + 'numeric(18,18)' => { data_type => 'numeric', size => [18,18] }, + + # Date and Time Types + 'date' => { data_type => 'date' }, + 'timestamp DEFAULT CURRENT_TIMESTAMP' + => { data_type => 'timestamp', default_value => \"CURRENT_TIMESTAMP" }, + 'time' => { data_type => 'time' }, + + # String Types + 'char' => { data_type => 'char', size => 1 }, + 'char(11)' => { data_type => 'char', size => 11 }, + 'varchar(20)' => { data_type => 'varchar', size => 20 }, + + # Blob types + 'blob' => { data_type => 'blob' }, + 'blob sub_type text' + => { data_type => 'blob sub_type text' }, + }, extra => { count => 7, run => sub { diff --git a/t/lib/dbixcsl_common_tests.pm b/t/lib/dbixcsl_common_tests.pm index f88dc5c..5fc3a01 100644 --- a/t/lib/dbixcsl_common_tests.pm +++ b/t/lib/dbixcsl_common_tests.pm @@ -114,14 +114,18 @@ sub run_only_extra_tests { @{$self}{qw/dsn user password connect_info_opts/} = @$info; - my $dbh = $self->dbconnect(0); + $self->drop_extra_tables_only; + + my $dbh = $self->dbconnect(1); $dbh->do($_) for @{ $self->{extra}{create} || [] }; $dbh->do($self->{data_type_tests}{ddl}) if $self->{data_type_tests}{ddl}; $self->{_created} = 1; - my $result_count = grep /CREATE (?:TABLE|VIEW)/i, @{ $self->{extra}{create} || [] }; + my $file_count = grep /CREATE (?:TABLE|VIEW)/i, @{ $self->{extra}{create} || [] }; + $file_count++; # schema + $file_count++ if $self->{data_type_tests}{ddl}; - my $schema_class = $self->setup_schema($info, $result_count + 2); # + schema + data_type table + my $schema_class = $self->setup_schema($info, $file_count); my ($monikers, $classes) = $self->monikers_and_classes($schema_class); my $conn = $schema_class->clone; @@ -129,13 +133,24 @@ sub run_only_extra_tests { $self->{extra}{run}->($conn, $monikers, $classes) if $self->{extra}{run}; if (not ($ENV{SCHEMA_LOADER_TESTS_NOCLEANUP} && $info_idx == $#$connect_info)) { - $dbh->do($_) for @{ $self->{extra}{pre_drop_ddl} || [] }; - $dbh->do("DROP TABLE $_") for @{ $self->{extra}{drop} || [] }; + $self->drop_extra_tables_only; rmtree $DUMP_DIR; } } } +sub drop_extra_tables_only { + my $self = shift; + + my $dbh = $self->dbconnect(0); + $dbh->do($_) for @{ $self->{extra}{pre_drop_ddl} || [] }; + $dbh->do("DROP TABLE $_") for @{ $self->{extra}{drop} || [] }; + + if (my $data_type_table = $self->{data_type_tests}{table_name}) { + $dbh->do("DROP TABLE $data_type_table"); + } +} + # defined in sub create my (@statements, @statements_reltests, @statements_advanced, @statements_advanced_sqlite, @statements_inline_rels, @@ -236,7 +251,8 @@ sub setup_schema { } else { SKIP: { - is scalar(@loader_warnings), $warn_count, 'Correct number of warnings'; + is scalar(@loader_warnings), $warn_count, 'Correct number of warnings' + or diag @loader_warnings; skip "not testing standard sources", 1; } } @@ -1626,6 +1642,11 @@ sub setup_data_type_tests { $size =~ s/\s+//g; my @size = split /,/, $size; + # Firebird doesn't like very long column names + if ($self->{vendor} =~ /^firebird\z/i) { + $type_alias =~ s/default\b.*/_with_dflt/i; + } + $type_alias =~ s/\s/_/g; $type_alias =~ s/\W//g;