X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FDBIx%2FClass%2FStorage%2FDBI%2FCursor.pm;h=4f591d077b2b284e991e55b0af1c3310ae11256f;hb=3d56e0269f018071841218af861bfa07df6bf01b;hp=c9dedf652d127640448d4dd1301fcb6ede29ed3c;hpb=dbaee7482fe6ff190e8ae53d609d0294b911339b;p=dbsrgits%2FDBIx-Class-Historic.git diff --git a/lib/DBIx/Class/Storage/DBI/Cursor.pm b/lib/DBIx/Class/Storage/DBI/Cursor.pm index c9dedf6..4f591d0 100644 --- a/lib/DBIx/Class/Storage/DBI/Cursor.pm +++ b/lib/DBIx/Class/Storage/DBI/Cursor.pm @@ -1,10 +1,20 @@ package DBIx::Class::Storage::DBI::Cursor; -use base qw/DBIx::Class::Cursor/; - use strict; use warnings; +use base 'DBIx::Class::Cursor'; + +use Try::Tiny; +use Scalar::Util qw(refaddr weaken); +use List::Util 'shuffle'; +use DBIx::Class::_Util 'detect_reinvoked_destructor'; +use namespace::clean; + +__PACKAGE__->mk_group_accessors('simple' => + qw/storage args attrs/ +); + =head1 NAME DBIx::Class::Storage::DBI::Cursor - Object representing a query cursor on a @@ -13,7 +23,12 @@ resultset. =head1 SYNOPSIS my $cursor = $schema->resultset('CD')->cursor(); - my $first_cd = $cursor->next; + + # raw values off the database handle in resultset columns/select order + my @next_cd_column_values = $cursor->next; + + # list of all raw values as arrayrefs + my @all_cds_column_values = $cursor->all; =head1 DESCRIPTION @@ -34,19 +49,42 @@ Returns a new L object. =cut -sub new { - my ($class, $storage, $args, $attrs) = @_; - #use Data::Dumper; warn Dumper(@_); - $class = ref $class if ref $class; - my $new = { - storage => $storage, - args => $args, - pos => 0, - attrs => $attrs, - _dbh_gen => $storage->{_dbh_gen}, - }; - - return bless ($new, $class); +{ + my %cursor_registry; + + sub new { + my ($class, $storage, $args, $attrs) = @_; + + my $self = bless { + storage => $storage, + args => $args, + attrs => $attrs, + }, ref $class || $class; + + if (DBIx::Class::_ENV_::HAS_ITHREADS) { + + # quick "garbage collection" pass - prevents the registry + # from slowly growing with a bunch of undef-valued keys + defined $cursor_registry{$_} or delete $cursor_registry{$_} + for keys %cursor_registry; + + weaken( $cursor_registry{ refaddr($self) } = $self ) + } + + return $self; + } + + sub CLONE { + for (keys %cursor_registry) { + # once marked we no longer care about them, hence no + # need to keep in the registry, left alone renumber the + # keys (all addresses are now different) + my $self = delete $cursor_registry{$_} + or next; + + $self->{_intra_thread} = 1; + } + } } =head2 next @@ -59,42 +97,53 @@ sub new { =back -Advances the cursor to the next row and returns an arrayref of column values. +Advances the cursor to the next row and returns an array of column +values (the result of L method). =cut -sub _dbh_next { - my ($storage, $dbh, $self) = @_; +sub next { + my $self = shift; + + return if $self->{_done}; - $self->_check_dbh_gen; - if ($self->{attrs}{rows} && $self->{pos} >= $self->{attrs}{rows}) { - $self->{sth}->finish if $self->{sth}->{Active}; - delete $self->{sth}; - $self->{done} = 1; + my $sth; + + if ( + $self->{attrs}{software_limit} + && $self->{attrs}{rows} + && ($self->{_pos}||0) >= $self->{attrs}{rows} + ) { + if ($sth = $self->sth) { + # explicit finish will issue warnings, unlike the DESTROY below + $sth->finish if $sth->FETCH('Active'); + } + $self->{_done} = 1; + return; } - return if $self->{done}; - unless ($self->{sth}) { - $self->{sth} = ($storage->_select(@{$self->{args}}))[1]; - if ($self->{attrs}{software_limit}) { - if (my $offset = $self->{attrs}{offset}) { - $self->{sth}->fetch for 1 .. $offset; - } + + unless ($sth = $self->sth) { + (undef, $sth, undef) = $self->storage->_select( @{$self->{args}} ); + + $self->{_results} = [ (undef) x $sth->FETCH('NUM_OF_FIELDS') ]; + $sth->bind_columns( \( @{$self->{_results}} ) ); + + if ( $self->{attrs}{software_limit} and $self->{attrs}{offset} ) { + $sth->fetch for 1 .. $self->{attrs}{offset}; } + + $self->sth($sth); } - my @row = $self->{sth}->fetchrow_array; - if (@row) { - $self->{pos}++; + + if ($sth->fetch) { + $self->{_pos}++; + return @{$self->{_results}}; } else { - delete $self->{sth}; - $self->{done} = 1; + $self->{_done} = 1; + return (); } - return @row; } -sub next { - my ($self) = @_; - $self->{storage}->dbh_do($self->can('_dbh_next'), $self); -} =head2 all @@ -111,20 +160,65 @@ L. =cut -sub _dbh_all { - my ($storage, $dbh, $self) = @_; +sub all { + my $self = shift; + + # delegate to DBIC::Cursor which will delegate back to next() + if ($self->{attrs}{software_limit} + && ($self->{attrs}{offset} || $self->{attrs}{rows})) { + return $self->next::method(@_); + } + + my $sth; + + if ($sth = $self->sth) { + # explicit finish will issue warnings, unlike the DESTROY below + $sth->finish if ( ! $self->{_done} and $sth->FETCH('Active') ); + $self->sth(undef); + } - $self->_check_dbh_gen; - $self->{sth}->finish if $self->{sth}->{Active}; - delete $self->{sth}; - my ($rv, $sth) = $storage->_select(@{$self->{args}}); - return @{$sth->fetchall_arrayref}; + (undef, $sth) = $self->storage->_select( @{$self->{args}} ); + + return ( + DBIx::Class::_ENV_::SHUFFLE_UNORDERED_RESULTSETS + and + ! $self->{attrs}{order_by} + ) + ? shuffle @{$sth->fetchall_arrayref} + : @{$sth->fetchall_arrayref} + ; } -sub all { - my ($self) = @_; - return $self->SUPER::all if $self->{attrs}{rows}; - $self->{storage}->dbh_do($self->can('_dbh_all'), $self); +sub sth { + my $self = shift; + + if (@_) { + delete @{$self}{qw/_pos _done _pid _intra_thread/}; + + $self->{sth} = $_[0]; + $self->{_pid} = $$ if ! DBIx::Class::_ENV_::BROKEN_FORK and $_[0]; + } + elsif ($self->{sth} and ! $self->{_done}) { + + my $invalidate_handle_reason; + + if (DBIx::Class::_ENV_::HAS_ITHREADS and $self->{_intra_thread} ) { + $invalidate_handle_reason = 'Multi-thread'; + } + elsif (!DBIx::Class::_ENV_::BROKEN_FORK and $self->{_pid} != $$ ) { + $invalidate_handle_reason = 'Multi-process'; + } + + if ($invalidate_handle_reason) { + $self->storage->throw_exception("$invalidate_handle_reason access attempted while cursor in progress (position $self->{_pos})") + if $self->{_pos}; + + # reinvokes the reset logic above + $self->sth(undef); + } + } + + return $self->{sth}; } =head2 reset @@ -134,36 +228,45 @@ Resets the cursor to the beginning of the L. =cut sub reset { - my ($self) = @_; - - # No need to care about failures here - eval { $self->{sth}->finish if $self->{sth} && $self->{sth}->{Active} }; - $self->_soft_reset; + $_[0]->__finish_sth if $_[0]->{sth}; + $_[0]->sth(undef); } -sub _soft_reset { - my ($self) = @_; - delete $self->{sth}; - delete $self->{done}; - $self->{pos} = 0; - return $self; +sub DESTROY { + return if &detect_reinvoked_destructor; + + $_[0]->__finish_sth if $_[0]->{sth}; } -sub _check_dbh_gen { - my ($self) = @_; +sub __finish_sth { + # It is (sadly) extremely important to finish() handles we are about + # to lose (due to reset() or a DESTROY() ). $rs->reset is the closest + # thing the user has to getting to the underlying finish() API and some + # DBDs mandate this (e.g. DBD::InterBase will segfault, DBD::Sybase + # won't start a transaction sanely, etc) + # We also can't use the accessor here, as it will trigger a fork/thread + # check, and resetting a cursor in a child is perfectly valid - if($self->{_dbh_gen} != $self->{storage}->{_dbh_gen}) { - $self->{_dbh_gen} = $self->{storage}->{_dbh_gen}; - $self->_soft_reset; - } + my $self = shift; + + # No need to care about failures here + try { local $SIG{__WARN__} = sub {}; $self->{sth}->finish } if ( + $self->{sth} and ! try { ! $self->{sth}->FETCH('Active') } + ); } -sub DESTROY { - my ($self) = @_; +=head1 FURTHER QUESTIONS? - # None of the reasons this would die matter if we're in DESTROY anyways - eval { $self->{sth}->finish if $self->{sth} && $self->{sth}->{Active} }; -} +Check the list of L. + +=head1 COPYRIGHT AND LICENSE + +This module is free software L +by the L. You can +redistribute it and/or modify it under the same terms as the +L. + +=cut 1;