X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FDBIx%2FClass%2FStorage%2FDBI%2FCursor.pm;h=d9004315bb9ab76ae922ca5fc068e9b607dda8c5;hb=ddcc02d14d03169c54c65db9f0f446836483ba55;hp=3d5da26f6d9b837437d72f486b3dc6a4ed321941;hpb=b7c7995572f865613e5a1907189ac23d8b52c690;p=dbsrgits%2FDBIx-Class.git diff --git a/lib/DBIx/Class/Storage/DBI/Cursor.pm b/lib/DBIx/Class/Storage/DBI/Cursor.pm index 3d5da26..d900431 100644 --- a/lib/DBIx/Class/Storage/DBI/Cursor.pm +++ b/lib/DBIx/Class/Storage/DBI/Cursor.pm @@ -3,7 +3,16 @@ package DBIx::Class::Storage::DBI::Cursor; use strict; use warnings; -use base qw/DBIx::Class::Cursor/; +use base 'DBIx::Class::Cursor'; + +use Scalar::Util qw(refaddr weaken); +use List::Util 'shuffle'; +use DBIx::Class::_Util qw( detected_reinvoked_destructor dbic_internal_try ); +use namespace::clean; + +__PACKAGE__->mk_group_accessors('simple' => + qw/storage args attrs/ +); =head1 NAME @@ -13,7 +22,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 +48,42 @@ Returns a new L object. =cut -sub new { - my ($class, $storage, $args, $attrs) = @_; - $class = ref $class if ref $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; - my $new = { - storage => $storage, - args => $args, - pos => 0, - attrs => $attrs, - _dbh_gen => $storage->{_dbh_gen}, - }; + 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; - return bless ($new, $class); + $self->{_intra_thread} = 1; + } + } } =head2 next @@ -64,42 +101,48 @@ values (the result of L method). =cut -sub _dbh_next { - my ($storage, $dbh, $self) = @_; +sub next { + my $self = shift; + + return if $self->{_done}; + + my $sth; - $self->_check_dbh_gen; if ( $self->{attrs}{software_limit} && $self->{attrs}{rows} - && $self->{pos} >= $self->{attrs}{rows} + && ($self->{_pos}||0) >= $self->{attrs}{rows} ) { - $self->{sth}->finish if $self->{sth}->{Active}; - delete $self->{sth}; - $self->{done} = 1; + 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 @@ -116,24 +159,65 @@ L. =cut -sub _dbh_all { - my ($storage, $dbh, $self) = @_; - - $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}; -} - sub all { - my ($self) = @_; + 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; + return $self->next::method(@_); } - $self->{storage}->dbh_do($self->can('_dbh_all'), $self); + 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); + } + + (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 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 @@ -143,37 +227,54 @@ 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; - return undef; + $_[0]->__finish_sth if $_[0]->{sth}; + $_[0]->sth(undef); } -sub _soft_reset { - my ($self) = @_; - delete $self->{sth}; - delete $self->{done}; - $self->{pos} = 0; +sub DESTROY { + return if &detected_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 + dbic_internal_try { + local $SIG{__WARN__} = sub {}; + $self->{sth}->finish + } if ( + $self->{sth} + and + # weird double-negative to catch the case of ->FETCH throwing + # and attempt a finish *anyway* + ! dbic_internal_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 - local $@; - 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;