From: Rafael Kitover <rkitover@cpan.org>
Date: Thu, 4 Mar 2010 01:34:04 +0000 (-0500)
Subject: Firebird passes common tests
X-Git-Tag: 0.06000~67
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=4145a6f3b1d5ba46a566f9675b5563cee04cdc9b;p=dbsrgits%2FDBIx-Class-Schema-Loader.git

Firebird passes common tests
---

diff --git a/Changes b/Changes
index dfd6d40..4d93cc2 100644
--- a/Changes
+++ b/Changes
@@ -1,5 +1,6 @@
 Revision history for Perl extension DBIx::Class::Schema::Loader
 
+        - preliminary 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 78205bf..2b7f72f 100644
--- a/lib/DBIx/Class/Schema/Loader/DBI.pm
+++ b/lib/DBIx/Class/Schema/Loader/DBI.pm
@@ -328,7 +328,7 @@ sub _columns_info_for {
         my $colinfo = $result{$col};
         my $type_num = $colinfo->{data_type};
         my $type_name;
-        if(defined $type_num && $dbh->can('type_info')) {
+        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;
diff --git a/lib/DBIx/Class/Schema/Loader/DBI/InterBase.pm b/lib/DBIx/Class/Schema/Loader/DBI/InterBase.pm
index 0ab1b3f..97e5ce6 100644
--- a/lib/DBIx/Class/Schema/Loader/DBI/InterBase.pm
+++ b/lib/DBIx/Class/Schema/Loader/DBI/InterBase.pm
@@ -2,9 +2,11 @@ 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';
 
 our $VERSION = '0.05003';
 
@@ -116,19 +118,47 @@ SELECT t.rdb$trigger_source
 FROM rdb$triggers t
 WHERE t.rdb$relation_name = ?
 EOF
-
     $sth->execute($table);
 
     while (my ($trigger) = $sth->fetchrow_array) {
-        my ($trig_col, $generator) = $trigger =~
-/new\s*.\s*(\w+) \s* = \s* gen_id\s* \( \s* (\w+)/ix;
+        my @trig_cols = $trigger =~ /new\."?(\w+)/ig;
+
+        my ($generator) = $trigger =~
+/(?:gen_id\s* \( \s* |next \s* value \s* for \s*)(\w+)/ix;
 
-        if ($trig_col eq $column) {
+        if (first { lc($_) eq lc($column) } @trig_cols) {
             $extra_info{is_auto_increment} = 1;
             $extra_info{sequence}          = $generator;
         }
     }
 
+# 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';
+    }
+
+# get default
+    $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, 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;
+        }
+    }
+
     return \%extra_info;
 }
 
diff --git a/t/18firebird_common.t b/t/18firebird_common.t
index 895874d..6143e9d 100644
--- a/t/18firebird_common.t
+++ b/t/18firebird_common.t
@@ -42,5 +42,11 @@ if( !$dsn ) {
     $tester->skip_tests('You need to set the DBICTEST_FIREBIRD_DSN, _USER, and _PASS environment variables');
 }
 else {
+    # get rid of stupid warning from InterBase/GetInfo.pm
+    {
+        local $SIG{__WARN__} = sub {};
+        require DBD::InterBase;
+        require DBD::InterBase::GetInfo;
+    }
     $tester->run_tests();
 }
diff --git a/t/lib/dbixcsl_common_tests.pm b/t/lib/dbixcsl_common_tests.pm
index 1b3069f..30710e9 100644
--- a/t/lib/dbixcsl_common_tests.pm
+++ b/t/lib/dbixcsl_common_tests.pm
@@ -327,7 +327,7 @@ sub test_schema {
         is( $rsobj1->loader_test1_rsmeth, 'all is still well', 'Result set method' );
     }
     
-    ok( $class1->column_info('id')->{is_auto_increment}, 'is_auto_incrment detection' );
+    ok( $class1->column_info('id')->{is_auto_increment}, 'is_auto_increment detection' );
 
     my $obj    = $rsobj1->find(1);
     is( $obj->id,  1, "Find got the right row" );