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