Matt,
per your suggestion, attatched is the revised patch. Basically the same
logic, but this time the logic is stuffed into DBIC::SQL::Abstract::Pg,
instead of the storage class.
Let me know if there any other problems :)
Regards,
--d
Matt S Trout wrote:
On Thu, Jul 05, 2007 at 02:45:23PM +0900, Daisuke Maki wrote:
good to know that you're aware of these problems. thanks.
I guess I'll just locally patch my DBIC for now.
I only use Pg, so it does the job for me.
If you can redo the patch so it adds the feature via an SQLA subclass ala
the way the Oracle WhereJoins subclass works, I'd be willing to accept it
for the moment.
The thing I disliked is that you were putting SQL in storage.
meanwhile, is the SQL::Abstract discussion carried on elsewhere? I'd
love to at least poke around see what I can contribute.
I'm going to get the ball rolling on this list soon - don't see the point
in starting another one, we've got a load of ORM authors and interested
people on here already :)
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
_______________________________________________
List: http://lists.rawmode.org/cgi-bin/mailman/listinfo/dbix-class
Wiki: http://dbix-class.shadowcatsystems.co.uk/
IRC: irc.perl.org#dbix-class
SVN: http://dev.catalyst.perl.org/repos/bast/trunk/DBIx-Class/
Searchable Archive: http://www.mail-archive.com/dbix-class@lists.rawmode.org/
