[Bast-commits] r8618 - in DBIx-Class/0.08/trunk: lib/DBIx/Class/Storage/DBI t

[caelum at dev.catalyst.perl.org]

Author: caelum
Date: 2010-02-11 10:46:58 +0000 (Thu, 11 Feb 2010)
New Revision: 8618

Modified:
   DBIx-Class/0.08/trunk/lib/DBIx/Class/Storage/DBI/SQLAnywhere.pm
   DBIx-Class/0.08/trunk/t/749sybase_asa.t
Log:
savepoints for SQLAnywhere

Modified: DBIx-Class/0.08/trunk/lib/DBIx/Class/Storage/DBI/SQLAnywhere.pm
===================================================================
--- DBIx-Class/0.08/trunk/lib/DBIx/Class/Storage/DBI/SQLAnywhere.pm	2010-02-11 10:45:54 UTC (rev 8617)
+++ DBIx-Class/0.08/trunk/lib/DBIx/Class/Storage/DBI/SQLAnywhere.pm	2010-02-11 10:46:58 UTC (rev 8618)
@@ -122,6 +122,21 @@
   );
 }
 
+sub _svp_begin {
+    my ($self, $name) = @_;
+
+    $self->_get_dbh->do("SAVEPOINT $name");
+}
+
+# can't release savepoints that have been rolled back
+sub _svp_release { 1 }
+
+sub _svp_rollback {
+    my ($self, $name) = @_;
+
+    $self->_get_dbh->do("ROLLBACK TO SAVEPOINT $name")
+}
+
 1;
 
 =head1 AUTHOR

Modified: DBIx-Class/0.08/trunk/t/749sybase_asa.t
===================================================================
--- DBIx-Class/0.08/trunk/t/749sybase_asa.t	2010-02-11 10:45:54 UTC (rev 8617)
+++ DBIx-Class/0.08/trunk/t/749sybase_asa.t	2010-02-11 10:46:58 UTC (rev 8618)
@@ -28,7 +28,9 @@
 
   next unless $dsn;
 
-  my $schema = DBICTest::Schema->connect($dsn, $user, $pass);
+  my $schema = DBICTest::Schema->connect($dsn, $user, $pass, {
+    auto_savepoint => 1
+  });
 
   my $dbh = $schema->storage->dbh;
 
@@ -58,6 +60,28 @@
   $new->discard_changes;
   is($new->artistid, 66, 'Explicit PK assigned');
 
+# test savepoints
+  eval {
+    $schema->txn_do(sub {
+      eval {
+        $schema->txn_do(sub {
+          $ars->create({ name => 'in_savepoint' });
+          die "rolling back savepoint";
+        });
+      };
+      ok ((not $ars->search({ name => 'in_savepoint' })->first),
+        'savepoint rolled back');
+      $ars->create({ name => 'in_outer_txn' });
+      die "rolling back outer txn";
+    });
+  };
+
+  like $@, qr/rolling back outer txn/,
+    'correct exception for rollback';
+
+  ok ((not $ars->search({ name => 'in_outer_txn' })->first),
+    'outer txn rolled back');
+
 # test populate
   lives_ok (sub {
     my @pop;