From: Rafael Kitover <rkitover@cpan.org>
Date: Mon, 7 Mar 2011 04:22:57 +0000 (-0500)
Subject: fixup Firebird ODBC driver for DBD::ODBC 1.29
X-Git-Tag: v0.08191~69
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=e02b39b48c5cca4812acb88d0bb71443cd8c8ff9;p=dbsrgits%2FDBIx-Class.git

fixup Firebird ODBC driver for DBD::ODBC 1.29
---

diff --git a/Changes b/Changes
index 53da767..2d807dd 100644
--- a/Changes
+++ b/Changes
@@ -23,6 +23,7 @@ Revision history for DBIx::Class
           (sources not yet registered with a schema)
         - Automatically require the requested cursor class before use
           (RT#64795)
+        - Work around a Firebird ODBC driver bug exposed by DBD::ODBC 1.29
 
     * Misc
         - Only load Class::C3 and friends if necessary ($] < 5.010)
diff --git a/lib/DBIx/Class/Optional/Dependencies.pm b/lib/DBIx/Class/Optional/Dependencies.pm
index fbb19e3..d946fc1 100644
--- a/lib/DBIx/Class/Optional/Dependencies.pm
+++ b/lib/DBIx/Class/Optional/Dependencies.pm
@@ -70,6 +70,9 @@ my $rdbms_ase = {
 my $rdbms_db2 = {
   'DBD::DB2'                      => '0',
 };
+my $rdbms_firebird_odbc = {
+  'DBD::ODBC'                     => '0',
+};
 
 my $reqs = {
   dist => {
@@ -378,6 +381,15 @@ my $reqs = {
     },
   },
 
+  test_rdbms_firebird_odbc => {
+    req => {
+      $ENV{DBICTEST_FIREBIRD_ODBC_DSN}
+        ? (
+          %$rdbms_firebird_odbc,
+        ) : ()
+    },
+  },
+
   test_memcached => {
     req => {
       $ENV{DBICTEST_MEMCACHED}
diff --git a/lib/DBIx/Class/Storage/DBI/InterBase.pm b/lib/DBIx/Class/Storage/DBI/InterBase.pm
index 9651277..97c556b 100644
--- a/lib/DBIx/Class/Storage/DBI/InterBase.pm
+++ b/lib/DBIx/Class/Storage/DBI/InterBase.pm
@@ -96,21 +96,21 @@ EOF
 }
 
 sub _svp_begin {
-    my ($self, $name) = @_;
+  my ($self, $name) = @_;
 
-    $self->_get_dbh->do("SAVEPOINT $name");
+  $self->_dbh->do("SAVEPOINT $name");
 }
 
 sub _svp_release {
-    my ($self, $name) = @_;
+  my ($self, $name) = @_;
 
-    $self->_get_dbh->do("RELEASE SAVEPOINT $name");
+  $self->_dbh->do("RELEASE SAVEPOINT $name");
 }
 
 sub _svp_rollback {
-    my ($self, $name) = @_;
+  my ($self, $name) = @_;
 
-    $self->_get_dbh->do("ROLLBACK TO SAVEPOINT $name")
+  $self->_dbh->do("ROLLBACK TO SAVEPOINT $name")
 }
 
 sub _ping {
@@ -312,3 +312,4 @@ See L<DBIx::Class/AUTHOR> and L<DBIx::Class/CONTRIBUTORS>.
 You may distribute this code under the same terms as Perl itself.
 
 =cut
+# vim:sts=2 sw=2:
diff --git a/lib/DBIx/Class/Storage/DBI/ODBC/Firebird.pm b/lib/DBIx/Class/Storage/DBI/ODBC/Firebird.pm
index 0784e24..d4a5f50 100644
--- a/lib/DBIx/Class/Storage/DBI/ODBC/Firebird.pm
+++ b/lib/DBIx/Class/Storage/DBI/ODBC/Firebird.pm
@@ -2,8 +2,10 @@ package DBIx::Class::Storage::DBI::ODBC::Firebird;
 
 use strict;
 use warnings;
-use base qw/DBIx::Class::Storage::DBI::InterBase/;
+use base 'DBIx::Class::Storage::DBI::InterBase';
 use mro 'c3';
+use Try::Tiny;
+use namespace::clean;
 
 =head1 NAME
 
@@ -37,9 +39,23 @@ sub _init { 1 }
 # ODBC uses dialect 3 by default, good
 sub _set_sql_dialect { 1 }
 
-# releasing savepoints doesn't work, but that shouldn't matter
+# releasing savepoints doesn't work for some reason, but that shouldn't matter
 sub _svp_release { 1 }
 
+sub _svp_rollback {
+  my ($self, $name) = @_;
+
+  try {
+    $self->_dbh->do("ROLLBACK TO SAVEPOINT $name")
+  }
+  catch {
+    # Firebird ODBC driver bug, ignore
+    if (not /Unable to fetch information about the error/) {
+      $self->throw_exception($_);
+    }
+  };
+}
+
 package # hide from PAUSE
   DBIx::Class::Storage::DBI::ODBC::Firebird::DateTime::Format;
 
@@ -91,3 +107,4 @@ See L<DBIx::Class/AUTHOR> and L<DBIx::Class/CONTRIBUTORS>.
 You may distribute this code under the same terms as Perl itself.
 
 =cut
+# vim:sts=2 sw=2:
diff --git a/t/750firebird.t b/t/750firebird.t
index 733f390..26927bf 100644
--- a/t/750firebird.t
+++ b/t/750firebird.t
@@ -100,6 +100,17 @@ EOF
   my $st = $schema->resultset('SequenceTest')->create({ name => 'foo', pkid1 => 55 });
   is($st->pkid1, 55, "Firebird Auto-PK without trigger: First primary key set manually");
 
+# test transaction commit
+  $schema->txn_do(sub {
+    $ars->create({ name => 'in_transaction' });
+  });
+  ok (($ars->search({ name => 'in_transaction' })->first),
+    'transaction committed');
+  is $schema->storage->_dbh->{AutoCommit}, 1,
+    '$dbh->{AutoCommit} is correct after transaction commit';
+
+  $ars->search({ name => 'in_transaction' })->delete;
+
 # test savepoints
   throws_ok {
     $schema->txn_do(sub {
@@ -117,6 +128,9 @@ EOF
   } qr/rolling back outer txn/,
     'correct exception for rollback';
 
+  is $schema->storage->_dbh->{AutoCommit}, 1,
+    '$dbh->{AutoCommit} is correct after transaction rollback';
+
   ok ((not $ars->search({ name => 'in_outer_txn' })->first),
     'outer txn rolled back');