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)
@@ -1,18 +1,51 @@
package DBIx::Class::Storage::DBI::Pg;
-
use strict;
use warnings;
-
use DBD::Pg qw(:pg_types);
-
use base qw/DBIx::Class::Storage::DBI/;
+BEGIN
+{
+
+# Temporary hack until we can fix SQL::Abstract
+package DBIC::SQL::Abstract::Pg;
+use strict;
+use base qw/DBIC::SQL::Abstract/;
+
+sub select {
+ my $self = shift;
+ my ($sql, @rest) = $self->SUPER::select(@_);
+
+ $sql .=
+ $self->{locking} ?
+ (
+ $self->{locking} eq 'update' ? 'FOR UPDATE' :
+ $self->{locking} eq 'share' ? 'FOR SHARE' :
+ ''
+ ) :
+ ''
+ ;
+ return wantarray ? ($sql, @rest) : $sql;
+}
+
+}
+
+
# __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};
+ my $sql_maker = $self->sql_maker;
+ local $sql_maker->{locking} = $locking;
+ $self->next::method(@_);
+}
+
sub _dbh_last_insert_id {
my ($self, $dbh, $seq) = @_;
$dbh->last_insert_id(undef, undef, undef, undef, {sequence => $seq});
@@ -73,6 +106,18 @@
}
}
+sub sql_maker {
+ my ($self) = @_;
+
+ unless ($self->_sql_maker) {
+ $self->_sql_maker(
+ new DBIC::SQL::Abstract::Pg( $self->_sql_maker_args )
+ );
+ }
+
+ return $self->_sql_maker;
+}
+
1;
=head1 NAME
