support for unicode Firebird data types

diff --git a/Changes b/Changes
index 67166f8..2e4a326 100644 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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<DBIx::Class::Schema::Loader::Base> 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 (file)
--- 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;
+            }
         },
     },
 );