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