lib/DBIx/Class/Storage/DBI/Cursor.pm

   1 package DBIx::Class::Storage::DBI::Cursor;
   2
   3 use strict;
   4 use warnings;
   5
   6 use base 'DBIx::Class::Cursor';
   7
   8 use Scalar::Util qw(refaddr weaken);
   9 use DBIx::Class::_Util qw( detected_reinvoked_destructor dbic_internal_try );
  10 use namespace::clean;
  11
  12 __PACKAGE__->mk_group_accessors('simple' =>
  13     qw/storage args attrs/
  14 );
  15
  16 =head1 NAME
  17
  18 DBIx::Class::Storage::DBI::Cursor - Object representing a query cursor on a
  19 resultset.
  20
  21 =head1 SYNOPSIS
  22
  23   my $cursor = $schema->resultset('CD')->cursor();
  24
  25   # raw values off the database handle in resultset columns/select order
  26   my @next_cd_column_values = $cursor->next;
  27
  28   # list of all raw values as arrayrefs
  29   my @all_cds_column_values = $cursor->all;
  30
  31 =head1 DESCRIPTION
  32
  33 A Cursor represents a query cursor on a L<DBIx::Class::ResultSet> object. It
  34 allows for traversing the result set with L</next>, retrieving all results with
  35 L</all> and resetting the cursor with L</reset>.
  36
  37 Usually, you would use the cursor methods built into L<DBIx::Class::ResultSet>
  38 to traverse it. See L<DBIx::Class::ResultSet/next>,
  39 L<DBIx::Class::ResultSet/reset> and L<DBIx::Class::ResultSet/all> for more
  40 information.
  41
  42 =head1 METHODS
  43
  44 =head2 new
  45
  46 Returns a new L<DBIx::Class::Storage::DBI::Cursor> object.
  47
  48 =cut
  49
  50 {
  51   my %cursor_registry;
  52
  53   sub new {
  54     my ($class, $storage, $args, $attrs) = @_;
  55
  56     my $self = bless {
  57       storage => $storage,
  58       args => $args,
  59       attrs => $attrs,
  60     }, ref $class || $class;
  61
  62     if (DBIx::Class::_ENV_::HAS_ITHREADS) {
  63
  64       # quick "garbage collection" pass - prevents the registry
  65       # from slowly growing with a bunch of undef-valued keys
  66       defined $cursor_registry{$_} or delete $cursor_registry{$_}
  67         for keys %cursor_registry;
  68
  69       weaken( $cursor_registry{ refaddr($self) } = $self )
  70     }
  71
  72     return $self;
  73   }
  74
  75   sub DBIx::Class::__DBI_Cursor_iThreads_handler__::CLONE {
  76     for (keys %cursor_registry) {
  77       # once marked we no longer care about them, hence no
  78       # need to keep in the registry, left alone renumber the
  79       # keys (all addresses are now different)
  80       my $self = delete $cursor_registry{$_}
  81         or next;
  82
  83       $self->{_intra_thread} = 1;
  84     }
  85
  86     # Dummy NEXTSTATE ensuring the all temporaries on the stack are garbage
  87     # collected before leaving this scope. Depending on the code above, this
  88     # may very well be just a preventive measure guarding future modifications
  89     undef;
  90   }
  91 }
  92
  93 =head2 next
  94
  95 =over 4
  96
  97 =item Arguments: none
  98
  99 =item Return Value: \@row_columns
 100
 101 =back
 102
 103 Advances the cursor to the next row and returns an array of column
 104 values (the result of L<DBI/fetchrow_array> method).
 105
 106 =cut
 107
 108 sub next {
 109   my $self = shift;
 110
 111   return if $self->{_done};
 112
 113   my $sth;
 114
 115   if (
 116     $self->{attrs}{software_limit}
 117       && $self->{attrs}{rows}
 118         && ($self->{_pos}||0) >= $self->{attrs}{rows}
 119   ) {
 120     if ($sth = $self->sth) {
 121       # explicit finish will issue warnings, unlike the DESTROY below
 122       $sth->finish if $sth->FETCH('Active');
 123     }
 124     $self->{_done} = 1;
 125     return;
 126   }
 127
 128   unless ($sth = $self->sth) {
 129     (undef, $sth, undef) = $self->storage->_select( @{$self->{args}} );
 130
 131     $self->{_results} = [ (undef) x $sth->FETCH('NUM_OF_FIELDS') ];
 132     $sth->bind_columns( \( @{$self->{_results}} ) );
 133
 134     if ( $self->{attrs}{software_limit} and $self->{attrs}{offset} ) {
 135       $sth->fetch for 1 .. $self->{attrs}{offset};
 136     }
 137
 138     $self->sth($sth);
 139   }
 140
 141   if ($sth->fetch) {
 142     $self->{_pos}++;
 143     return @{$self->{_results}};
 144   } else {
 145     $self->{_done} = 1;
 146     return ();
 147   }
 148 }
 149
 150
 151 =head2 all
 152
 153 =over 4
 154
 155 =item Arguments: none
 156
 157 =item Return Value: \@row_columns+
 158
 159 =back
 160
 161 Returns a list of arrayrefs of column values for all rows in the
 162 L<DBIx::Class::ResultSet>.
 163
 164 =cut
 165
 166 sub all {
 167   my $self = shift;
 168
 169   # delegate to DBIC::Cursor which will delegate back to next()
 170   if ($self->{attrs}{software_limit}
 171         && ($self->{attrs}{offset} || $self->{attrs}{rows})) {
 172     return $self->next::method(@_);
 173   }
 174
 175   my $sth;
 176
 177   if ($sth = $self->sth) {
 178     # explicit finish will issue warnings, unlike the DESTROY below
 179     $sth->finish if ( ! $self->{_done} and $sth->FETCH('Active') );
 180     $self->sth(undef);
 181   }
 182
 183   (undef, $sth) = $self->storage->_select( @{$self->{args}} );
 184
 185   (
 186     DBIx::Class::_ENV_::SHUFFLE_UNORDERED_RESULTSETS
 187       and
 188     ! $self->{attrs}{order_by}
 189       and
 190     require List::Util
 191   )
 192     ? List::Util::shuffle( @{$sth->fetchall_arrayref} )
 193     : @{$sth->fetchall_arrayref}
 194   ;
 195 }
 196
 197 sub sth {
 198   my $self = shift;
 199
 200   if (@_) {
 201     delete @{$self}{qw/_pos _done _pid _intra_thread/};
 202
 203     $self->{sth} = $_[0];
 204     $self->{_pid} = $$ if ! DBIx::Class::_ENV_::BROKEN_FORK and $_[0];
 205   }
 206   elsif ($self->{sth} and ! $self->{_done}) {
 207
 208     my $invalidate_handle_reason;
 209
 210     if (DBIx::Class::_ENV_::HAS_ITHREADS and $self->{_intra_thread} ) {
 211       $invalidate_handle_reason = 'Multi-thread';
 212     }
 213     elsif (!DBIx::Class::_ENV_::BROKEN_FORK and $self->{_pid} != $$ ) {
 214       $invalidate_handle_reason = 'Multi-process';
 215     }
 216
 217     if ($invalidate_handle_reason) {
 218       $self->storage->throw_exception("$invalidate_handle_reason access attempted while cursor in progress (position $self->{_pos})")
 219         if $self->{_pos};
 220
 221       # reinvokes the reset logic above
 222       $self->sth(undef);
 223     }
 224   }
 225
 226   return $self->{sth};
 227 }
 228
 229 =head2 reset
 230
 231 Resets the cursor to the beginning of the L<DBIx::Class::ResultSet>.
 232
 233 =cut
 234
 235 sub reset {
 236   $_[0]->__finish_sth if $_[0]->{sth};
 237   $_[0]->sth(undef);
 238
 239   # Dummy NEXTSTATE ensuring the all temporaries on the stack are garbage
 240   # collected before leaving this scope. Depending on the code above, this
 241   # may very well be just a preventive measure guarding future modifications
 242   undef;
 243 }
 244
 245
 246 sub DESTROY {
 247   return if &detected_reinvoked_destructor;
 248
 249   $_[0]->__finish_sth if $_[0]->{sth};
 250
 251   # Dummy NEXTSTATE ensuring the all temporaries on the stack are garbage
 252   # collected before leaving this scope. Depending on the code above, this
 253   # may very well be just a preventive measure guarding future modifications
 254   undef;
 255 }
 256
 257 sub __finish_sth {
 258   # It is (sadly) extremely important to finish() handles we are about
 259   # to lose (due to reset() or a DESTROY() ). $rs->reset is the closest
 260   # thing the user has to getting to the underlying finish() API and some
 261   # DBDs mandate this (e.g. DBD::InterBase will segfault, DBD::Sybase
 262   # won't start a transaction sanely, etc)
 263   # We also can't use the accessor here, as it will trigger a fork/thread
 264   # check, and resetting a cursor in a child is perfectly valid
 265
 266   my $self = shift;
 267
 268   # No need to care about failures here
 269   dbic_internal_try {
 270     local $SIG{__WARN__} = sub {};
 271     $self->{sth}->finish
 272   } if (
 273     $self->{sth}
 274       and
 275     # weird double-negative to catch the case of ->FETCH throwing
 276     # and attempt a finish *anyway*
 277     ! dbic_internal_try {
 278       ! $self->{sth}->FETCH('Active')
 279     }
 280   );
 281
 282   # Dummy NEXTSTATE ensuring the all temporaries on the stack are garbage
 283   # collected before leaving this scope. Depending on the code above, this
 284   # may very well be just a preventive measure guarding future modifications
 285   undef;
 286 }
 287
 288 =head1 FURTHER QUESTIONS?
 289
 290 Check the list of L<additional DBIC resources|DBIx::Class/GETTING HELP/SUPPORT>.
 291
 292 =head1 COPYRIGHT AND LICENSE
 293
 294 This module is free software L<copyright|DBIx::Class/COPYRIGHT AND LICENSE>
 295 by the L<DBIx::Class (DBIC) authors|DBIx::Class/AUTHORS>. You can
 296 redistribute it and/or modify it under the same terms as the
 297 L<DBIx::Class library|DBIx::Class/COPYRIGHT AND LICENSE>.
 298
 299 =cut
 300
 301 1;