[Dbix-class] SELECT .. FOR UPDATE with DBIx::Class

[Daisuke Maki]

Hi,

I've been looking for a way to do SELECT FOR UPDATE via DBIx::Class, and
found this:

  http://lists.rawmode.org/pipermail/dbix-class/2007-March/003568.html

I don't think this is implemented yet, so I've given it a try.

Attached is a patch (with tests) against trunk. The tests requires an
extra module, Sys::SigAction, so the new tests will be skipped if
Sys::SigAction is not available.

Let me know if it look reasonable.

Regards,
--d
-------------- next part --------------
Index: t/72pg.t
===================================================================
--- t/72pg.t	(revision 3567)
+++ t/72pg.t	(working copy)
@@ -27,7 +27,7 @@
 plan skip_all => 'Set $ENV{DBICTEST_PG_DSN}, _USER and _PASS to run this test'
  . ' (note: creates and drops tables named artist and casecheck!)' unless ($dsn && $user);
 
-plan tests => 8;
+plan tests => 14;
 
 DBICTest::Schema->load_classes( 'Casecheck' );
 my $schema = DBICTest::Schema->connect($dsn, $user, $pass);
@@ -87,6 +87,83 @@
 my $uc_name_info = $schema->source('Casecheck')->column_info( 'uc_name' );
 is( $uc_name_info->{size}, 3, "Case insensitive matching info for 'uc_name'" );
 
+# Test SELECT ... FOR UPDATE
+my $HaveSysSigAction = eval "require Sys::SigAction" && !$@;
+if ($HaveSysSigAction) {
+    Sys::SigAction->import( 'set_sig_handler' );
+}
+
+SKIP: {
+    skip "Sys::SigAction is not available", 3 unless $HaveSysSigAction;
+    # create a new schema
+    my $schema2 = DBICTest::Schema->connect($dsn, $user, $pass);
+    $schema2->source("Artist")->name("testschema.artist");
+
+    $schema->txn_do( sub {
+        my $artist = $schema->resultset('Artist')->search(
+            {
+                artistid => 1
+            },
+            {
+                locking => 'update'
+            }
+        )->first;
+        is($artist->artistid, 1, "select for update returns artistid = 1");
+
+        my $artist_from_schema2;
+        my $error_ok = 0;
+        eval {
+            my $h = set_sig_handler( 'ALRM', sub { die "DBICTestTimeout" } );
+            alarm(2);
+            $artist_from_schema2 = $schema2->resultset('Artist')->find(1);
+            $artist_from_schema2->name('fooey');
+            $artist_from_schema2->update;
+            alarm(0);
+        };
+        if (my $e = $@) {
+            $error_ok = $e =~ /DBICTestTimeout/;
+        }
+
+        # Make sure that an error was raised, and that the update failed
+        ok($error_ok, "update from second schema times out");
+        ok($artist_from_schema2->is_column_changed('name'), "'name' column is still dirty from second schema");
+    });
+}
+
+SKIP: {
+    skip "Sys::SigAction is not available", 3 unless $HaveSysSigAction;
+    # create a new schema
+    my $schema2 = DBICTest::Schema->connect($dsn, $user, $pass);
+    $schema2->source("Artist")->name("testschema.artist");
+
+    $schema->txn_do( sub {
+        my $artist = $schema->resultset('Artist')->search(
+            {
+                artistid => 1
+            },
+        )->first;
+        is($artist->artistid, 1, "select for update returns artistid = 1");
+
+        my $artist_from_schema2;
+        my $error_ok = 0;
+        eval {
+            my $h = set_sig_handler( 'ALRM', sub { die "DBICTestTimeout" } );
+            alarm(2);
+            $artist_from_schema2 = $schema2->resultset('Artist')->find(1);
+            $artist_from_schema2->name('fooey');
+            $artist_from_schema2->update;
+            alarm(0);
+        };
+        if (my $e = $@) {
+            $error_ok = $e =~ /DBICTestTimeout/;
+        }
+
+        # Make sure that an error was raised, and that the update failed
+        ok(! $error_ok, "update from second schema DOES NOT timeout");
+        ok(! $artist_from_schema2->is_column_changed('name'), "'name' column is NOT dirty from second schema");
+    });
+}
+
 END {
     if($dbh) {
         $dbh->do("DROP TABLE testschema.artist;");
Index: lib/DBIx/Class/Storage/DBI/Pg.pm
===================================================================
--- lib/DBIx/Class/Storage/DBI/Pg.pm	(revision 3567)
+++ lib/DBIx/Class/Storage/DBI/Pg.pm	(working copy)
@@ -7,12 +7,35 @@
 
 use base qw/DBIx::Class::Storage::DBI/;
 
+our $_LOCKING = undef;
+
 # __PACKAGE__->load_components(qw/PK::Auto/);
 
 # Warn about problematic versions of DBD::Pg
 warn "DBD::Pg 1.49 is strongly recommended"
   if ($DBD::Pg::VERSION < 1.49);
 
+sub _select {
+    my $self = shift;
+
+    my $locking = delete $_[3]->{locking};
+    local $_LOCKING = $locking && $locking =~ /^(?:update|share)$/ ? $locking : undef;
+    $self->next::method(@_);
+}
+
+sub sth {
+    my ($self, $sql) = @_;
+
+    if ($_LOCKING) {
+        # XXX Should really be checking if this is a select statement
+        $sql .= $_LOCKING eq 'update' ? 'FOR UPDATE' :
+                $_LOCKING eq 'share'  ? 'FOR SHARE'  :
+                ''
+        ;
+    }
+    $self->SUPER::sth($sql);
+}
+
 sub _dbh_last_insert_id {
   my ($self, $dbh, $seq) = @_;
   $dbh->last_insert_id(undef, undef, undef, undef, {sequence => $seq});