Attached you should find a working version of a patch originally by
Daisuke Maki. I had to modify it so it works, again. I'm presuming
it did work when Daisuke whipped it up back in July... The original
is here:
http://lists.scsys.co.uk/pipermail/dbix-class/2007-July/004577.html.
I wasn't able to test the Oracle change since I don't have Oracle. I
did test the Pg portion and it all passed.
jdvIndex: 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 = 10;
+plan tests = 16;
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
+},
+{
+for = '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 NOT raised, and that the update succeeded
+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.pm
===
--- lib/DBIx/Class/Storage/DBI.pm (revision 3567)
+++ lib/DBIx/Class/Storage/DBI.pm (working copy)
@@ -17,6 +17,9 @@
transaction_depth unsafe/
);
+__PACKAGE__-mk_group_accessors('inherited' = qw/sql_maker_class/);
+__PACKAGE__-sql_maker_class('DBIC::SQL::Abstract');
+
BEGIN {
package DBIC::SQL::Abstract; # Would merge upstream, but nate doesn't reply :(
@@ -81,6 +84,15 @@
my ($sql, @ret) = $self-SUPER::select(
$table, $self-_recurse_fields($fields), $where, $order, @rest
);
+ $sql .=
+$self-{for} ?
+(
+ $self-{for} eq 'update' ? ' FOR UPDATE' :
+ $self-{for} eq 'shared' ? ' FOR SHARE' :
+ ''
+) :
+''
+ ;
return wantarray ? ($sql, @ret, @{$self-{having_bind}}) : $sql;
}
@@ -711,7 +723,8 @@
sub sql_maker {
my ($self) = @_;
unless ($self-_sql_maker) {
-$self-_sql_maker(new DBIC::SQL::Abstract( $self-_sql_maker_args ));
+my $sql_maker_class = $self-sql_maker_class;
+$self-_sql_maker($sql_maker_class-new( $self-_sql_maker_args ));
}
return $self-_sql_maker;
}
@@ -1003,9 +1016,15 @@
sub _select {
my ($self, $ident, $select,
