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 qw/DBIx::Class::Cursor/;
   7
   8 use Try::Tiny;
   9 use Scalar::Util qw/refaddr weaken/;
  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 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 }
  87
  88 =head2 next
  89
  90 =over 4
  91
  92 =item Arguments: none
  93
  94 =item Return Value: \@row_columns
  95
  96 =back
  97
  98 Advances the cursor to the next row and returns an array of column
  99 values (the result of L<DBI/fetchrow_array> method).
 100
 101 =cut
 102
 103 sub next {
 104   my $self = shift;
 105
 106   return if $self->{_done};
 107
 108   my $sth;
 109
 110   if (
 111     $self->{attrs}{software_limit}
 112       && $self->{attrs}{rows}
 113         && ($self->{_pos}||0) >= $self->{attrs}{rows}
 114   ) {
 115     if ($sth = $self->sth) {
 116       # explicit finish will issue warnings, unlike the DESTROY below
 117       $sth->finish if $sth->FETCH('Active');
 118     }
 119     $self->{_done} = 1;
 120     return;
 121   }
 122
 123   unless ($sth = $self->sth) {
 124     (undef, $sth, undef) = $self->storage->_select( @{$self->{args}} );
 125
 126     $self->{_results} = [ (undef) x $sth->FETCH('NUM_OF_FIELDS') ];
 127     $sth->bind_columns( \( @{$self->{_results}} ) );
 128
 129     if ( $self->{attrs}{software_limit} and $self->{attrs}{offset} ) {
 130       $sth->fetch for 1 .. $self->{attrs}{offset};
 131     }
 132
 133     $self->sth($sth);
 134   }
 135
 136   if ($sth->fetch) {
 137     $self->{_pos}++;
 138     return @{$self->{_results}};
 139   } else {
 140     $self->{_done} = 1;
 141     return ();
 142   }
 143 }
 144
 145
 146 =head2 all
 147
 148 =over 4
 149
 150 =item Arguments: none
 151
 152 =item Return Value: \@row_columns+
 153
 154 =back
 155
 156 Returns a list of arrayrefs of column values for all rows in the
 157 L<DBIx::Class::ResultSet>.
 158
 159 =cut
 160
 161 sub all {
 162   my $self = shift;
 163
 164   # delegate to DBIC::Cursor which will delegate back to next()
 165   if ($self->{attrs}{software_limit}
 166         && ($self->{attrs}{offset} || $self->{attrs}{rows})) {
 167     return $self->next::method(@_);
 168   }
 169
 170   my $sth;
 171
 172   if ($sth = $self->sth) {
 173     # explicit finish will issue warnings, unlike the DESTROY below
 174     $sth->finish if ( ! $self->{_done} and $sth->FETCH('Active') );
 175     $self->sth(undef);
 176   }
 177
 178   (undef, $sth) = $self->storage->_select( @{$self->{args}} );
 179
 180   return @{$sth->fetchall_arrayref};
 181 }
 182
 183 sub sth {
 184   my $self = shift;
 185
 186   if (@_) {
 187     delete @{$self}{qw/_pos _done _pid _intra_thread/};
 188
 189     $self->{sth} = $_[0];
 190     $self->{_pid} = $$ if ! DBIx::Class::_ENV_::BROKEN_FORK and $_[0];
 191   }
 192   elsif ($self->{sth} and ! $self->{_done}) {
 193
 194     my $invalidate_handle_reason;
 195
 196     if (DBIx::Class::_ENV_::HAS_ITHREADS and $self->{_intra_thread} ) {
 197       $invalidate_handle_reason = 'Multi-thread';
 198     }
 199     elsif (!DBIx::Class::_ENV_::BROKEN_FORK and $self->{_pid} != $$ ) {
 200       $invalidate_handle_reason = 'Multi-process';
 201     }
 202
 203     if ($invalidate_handle_reason) {
 204       $self->storage->throw_exception("$invalidate_handle_reason access attempted while cursor in progress (position $self->{_pos})")
 205         if $self->{_pos};
 206
 207       # reinvokes the reset logic above
 208       $self->sth(undef);
 209     }
 210   }
 211
 212   return $self->{sth};
 213 }
 214
 215 =head2 reset
 216
 217 Resets the cursor to the beginning of the L<DBIx::Class::ResultSet>.
 218
 219 =cut
 220
 221 sub reset {
 222   $_[0]->__finish_sth if $_[0]->{sth};
 223   $_[0]->sth(undef);
 224 }
 225
 226
 227 sub DESTROY {
 228   $_[0]->__finish_sth if $_[0]->{sth};
 229 }
 230
 231 sub __finish_sth {
 232   # It is (sadly) extremely important to finish() handles we are about
 233   # to lose (due to reset() or a DESTROY() ). $rs->reset is the closest
 234   # thing the user has to getting to the underlying finish() API and some
 235   # DBDs mandate this (e.g. DBD::InterBase will segfault, DBD::Sybase
 236   # won't start a transaction sanely, etc)
 237   # We also can't use the accessor here, as it will trigger a fork/thread
 238   # check, and resetting a cursor in a child is perfectly valid
 239
 240   my $self = shift;
 241
 242   # No need to care about failures here
 243   try { local $SIG{__WARN__} = sub {}; $self->{sth}->finish } if (
 244     $self->{sth} and ! try { ! $self->{sth}->FETCH('Active') }
 245   );
 246 }
 247
 248 1;