(sorry for the top-posting everybody) Can somebody with a pg test rig already set up verify this and commit it please?
On Mon, Sep 24, 2007 at 01:42:16AM -0400, Justin DeVuyst wrote: > 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. > > jdv > 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 => 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, $condition, $attrs) = @_; > my $order = $attrs->{order_by}; > + > if (ref $condition eq 'SCALAR') { > $order = $1 if $$condition =~ s/ORDER BY (.*)$//i; > } > + > + my $for = delete $attrs->{for}; > + my $sql_maker = $self->sql_maker; > + local $sql_maker->{for} = $for; > + > 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 > IRC: irc.perl.org#dbix-class > SVN: http://dev.catalyst.perl.org/repos/bast/DBIx-Class/ > Searchable Archive: http://www.grokbase.com/group/[EMAIL PROTECTED] -- Matt S Trout Need help with your Catalyst or DBIx::Class project? Technical Director http://www.shadowcat.co.uk/catalyst/ Shadowcat Systems Ltd. Want a managed development or deployment platform? http://chainsawblues.vox.com/ http://www.shadowcat.co.uk/servers/ _______________________________________________ List: http://lists.rawmode.org/cgi-bin/mailman/listinfo/dbix-class IRC: irc.perl.org#dbix-class SVN: http://dev.catalyst.perl.org/repos/bast/DBIx-Class/ Searchable Archive: http://www.grokbase.com/group/[EMAIL PROTECTED]
