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