Hello. I posted this solution only as a workaround. If it goes to core then it would be much better to implement a callback in Storage::DBI after $sql is generated but before $sth is generated. (for example, $sql = $self->tune_sql($sql, $attrs) in sub _dbh_execute) This would be the last change for Storage::DBI::* to implement some database-specific features like Pg's for update/share mysql's replace into / insert ignore / delayed updates / case-insensitive select, etc
$attrs are needed to be passed to _dbh_execute to do that. To DBIC developers: could you implement this (or similar) please? 2007/7/4, Daisuke Maki <[EMAIL PROTECTED]>:
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 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}); _______________________________________________ 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/
_______________________________________________ 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/
