(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/dbix-class@xxxxxxxxxxxxxxxxx
--
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/
|
