From: Rafael Kitover Date: Thu, 21 Apr 2011 02:22:39 +0000 (-0400) Subject: support for unicode Firebird data types X-Git-Tag: 0.07011~125 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=5111e5d05df2533febdcc8409792ebc9ef6837da;p=dbsrgits%2FDBIx-Class-Schema-Loader.git support for unicode Firebird data types --- diff --git a/Changes b/Changes index 67166f8..2e4a326 100644 --- a/Changes +++ b/Changes @@ -1,6 +1,7 @@ Revision history for Perl extension DBIx::Class::Schema::Loader - support for DBD::Firebird + - support for unicode Firebird data types 0.07010 2011-03-04 08:26:31 - add result_component_map option diff --git a/lib/DBIx/Class/Schema/Loader/DBI.pm b/lib/DBIx/Class/Schema/Loader/DBI.pm index f2eb64d..a7372eb 100644 --- a/lib/DBIx/Class/Schema/Loader/DBI.pm +++ b/lib/DBIx/Class/Schema/Loader/DBI.pm @@ -390,8 +390,7 @@ sub _columns_info_for { my $type_num = $colinfo->{data_type}; my $type_name; if (defined $type_num && $type_num =~ /^-?\d+\z/ && $dbh->can('type_info')) { - my $type_info = $self->_dbh_type_info($type_num); - $type_name = $type_info->{TYPE_NAME} if $type_info; + my $type_name = $self->_dbh_type_info_type_name($type_num); $colinfo->{data_type} = lc $type_name if $type_name; } } @@ -400,12 +399,14 @@ sub _columns_info_for { } # Need to override this for the buggy Firebird ODBC driver. -sub _dbh_type_info { +sub _dbh_type_info_type_name { my ($self, $type_num) = @_; my $dbh = $self->schema->storage->dbh; - return $dbh->type_info($type_num); + my $type_info = $dbh->type_info($type_num); + + return $type_info ? $type_info->{TYPE_NAME} : undef; } # do not use this, override _columns_info_for instead diff --git a/lib/DBIx/Class/Schema/Loader/DBI/InterBase.pm b/lib/DBIx/Class/Schema/Loader/DBI/InterBase.pm index 278f6eb..8490859 100644 --- a/lib/DBIx/Class/Schema/Loader/DBI/InterBase.pm +++ b/lib/DBIx/Class/Schema/Loader/DBI/InterBase.pm @@ -192,7 +192,7 @@ EOF # 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 +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' @@ -201,7 +201,7 @@ 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; + 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) { @@ -225,7 +225,12 @@ EOF $info->{data_type} = 'blob'; } elsif ($sub_type_name eq 'TEXT') { - $info->{data_type} = 'blob sub_type text'; + if ($char_set_id == 3) { + $info->{data_type} = 'blob sub_type text character set unicode_fss'; + } + else { + $info->{data_type} = 'blob sub_type text'; + } } } } @@ -262,11 +267,14 @@ EOF $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]; + if ($info->{data_type} =~ /^(?:char|varchar)\z/) { + $info->{size} = $char_length; + + if ($char_set_id == 3) { + $info->{data_type} .= '(x) character set unicode_fss'; + } } - elsif ($info->{data_type} !~ /^(?:char|varchar|numeric|decimal)\z/) { + elsif ($info->{data_type} !~ /^(?:numeric|decimal)\z/) { delete $info->{size}; } diff --git a/lib/DBIx/Class/Schema/Loader/DBI/ODBC/Firebird.pm b/lib/DBIx/Class/Schema/Loader/DBI/ODBC/Firebird.pm index ccabbaa..af8103f 100644 --- a/lib/DBIx/Class/Schema/Loader/DBI/ODBC/Firebird.pm +++ b/lib/DBIx/Class/Schema/Loader/DBI/ODBC/Firebird.pm @@ -26,7 +26,7 @@ See L for usage information. # Some (current) versions of the ODBC driver have a bug where ->type_info breaks # with "data truncated". This "fixes" it, but some type names are truncated. -sub _dbh_type_info { +sub _dbh_type_info_type_name { my ($self, $type_num) = @_; my $dbh = $self->schema->storage->dbh; @@ -34,7 +34,21 @@ sub _dbh_type_info { local $dbh->{LongReadLen} = 100_000; local $dbh->{LongTruncOk} = 1; - return $dbh->type_info($type_num); + my $type_info = $dbh->type_info($type_num); + + return undef if not $type_info; + + my $type_name = $type_info->{TYPE_NAME}; + + # fix up truncated type names + if ($type_name eq "VARCHAR(x) CHARACTER SET UNICODE_\0") { + return 'VARCHAR(x) CHARACTER SET UNICODE_FSS'; + } + elsif ($type_name eq "BLOB SUB_TYPE TEXT CHARACTER SET \0") { + return 'BLOB SUB_TYPE TEXT CHARACTER SET UNICODE_FSS'; + } + + return $type_name; } =head1 SEE ALSO diff --git a/t/10_09firebird_common.t b/t/10_09firebird_common.t index cd1014e..0dbbd11 100644 --- a/t/10_09firebird_common.t +++ b/t/10_09firebird_common.t @@ -104,14 +104,21 @@ my $tester = dbixcsl_common_tests->new( 'char' => { data_type => 'char', size => 1 }, 'char(11)' => { data_type => 'char', size => 11 }, 'varchar(20)' => { data_type => 'varchar', size => 20 }, + 'char(22) character set unicode_fss' => + => { data_type => 'char(x) character set unicode_fss', size => 22 }, + 'varchar(33) character set unicode_fss' => + => { data_type => 'varchar(x) character set unicode_fss', size => 33 }, + # Blob types 'blob' => { data_type => 'blob' }, 'blob sub_type text' => { data_type => 'blob sub_type text' }, + 'blob sub_type text character set unicode_fss' + => { data_type => 'blob sub_type text character set unicode_fss' }, }, extra => { - count => 6, + count => 9, run => sub { $schema = shift; my ($monikers, $classes, $self) = @_; @@ -162,6 +169,25 @@ q{ is $col_info->{sequence}, 'Gen_Firebird_Loader_Test1_Id', 'correct mixed case sequence name'; is eval { $rsrc->column_info('Foo')->{default_value} }, 42, 'default_value detected for mixed case column'; + + # test the fixed up ->_dbh_type_info_type_name for the ODBC driver + if ($schema->storage->_dbi_connect_info->[0] =~ /:ODBC:/i) { + my %truncated_types = ( + 4 => 'INTEGER', + -9 => 'VARCHAR(x) CHARACTER SET UNICODE_FSS', + -10 => 'BLOB SUB_TYPE TEXT CHARACTER SET UNICODE_FSS', + ); + + for my $type_num (keys %truncated_types) { + is $schema->_loader->_dbh_type_info_type_name($type_num), + $truncated_types{$type_num}, + "ODBC ->_dbh_type_info_type_name correct for '$truncated_types{$type_num}'"; + } + } + else { + my $tb = Test::More->builder; + $tb->skip('not testing _dbh_type_info_type_name on DBD::InterBase') for 1..3; + } }, }, );