Yeah, although (re your outline patch) I think it should be done as an
'inherited' type group accessor; that way the default can be set per-class
without having to add the _rebless hook.
Oh, *that's* how you use this accessor system...
grepping for 'inherited', I think I get it.
I was wondering about that.
Okay, so I've now done the following:
* Add sql_maker_class to DBIC::Storage::DBI as an inherited accessor
* Change DBIC::Storage::DBI->sql_maker so that it uses
sql_maker_class() to choose which class to instantiate
* Refactored Storage::DBI::Oracle::WhereJoins's sql_maker()
method (UNTESTED)
* Add support for "locking" attribute to DBIC::SQL::Abstract
(NOT DBIC::Storage::Pg), since we've identified Pg, mysql,
Oracle, and DB2 supporting this syntax.
I've only tested Pg, though. Hopefully somebody more knowledgeable and
with access to the other DBs can help me out here.
--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.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->{locking} ?
+ (
+ $self->{locking} eq 'update' ? 'FOR UPDATE' :
+ $self->{locking} eq 'share' ? '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, $condition, $attrs) = @_;
my $order = $attrs->{order_by};
+
if (ref $condition eq 'SCALAR') {
$order = $1 if $$condition =~ s/ORDER BY (.*)$//i;
}
+
+ my $locking = delete $attrs->{locking};
+ my $sql_maker = $self->sql_maker;
+ local $sql_maker->{locking} = $locking;
+
if (exists $attrs->{group_by} || $attrs->{having}) {
$order = {
group_by => $attrs->{group_by},
@@ -1023,6 +1042,7 @@
if (defined($attrs->{rows}) && !($attrs->{rows} > 0));
push @args, $attrs->{rows}, $attrs->{offset};
}
+
return $self->_execute(@args);
}
Index: lib/DBIx/Class/Storage/DBI/Oracle/WhereJoins.pm
===================================================================
--- lib/DBIx/Class/Storage/DBI/Oracle/WhereJoins.pm (revision 3567)
+++ lib/DBIx/Class/Storage/DBI/Oracle/WhereJoins.pm (working copy)
@@ -5,6 +5,8 @@
use strict;
use warnings;
+__PACKAGE__->sql_maker_class('DBIC::SQL::Abstract::Oracle');
+
BEGIN {
package DBIC::SQL::Abstract::Oracle;
@@ -91,18 +93,6 @@
}
}
-sub sql_maker {
- my ($self) = @_;
-
- unless ($self->_sql_maker) {
- $self->_sql_maker(
- new DBIC::SQL::Abstract::Oracle( $self->_sql_maker_args )
- );
- }
-
- return $self->_sql_maker;
-}
-
1;
__END__
_______________________________________________
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/
