Fix updating multiple CLOB/BLOB columns on Oracle
[dbsrgits/DBIx-Class.git] / 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 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   $_[0]->__finish_sth if $_[0]->{sth};
237 }
238
239 sub __finish_sth {
240   # It is (sadly) extremely important to finish() handles we are about
241   # to lose (due to reset() or a DESTROY() ). $rs->reset is the closest
242   # thing the user has to getting to the underlying finish() API and some
243   # DBDs mandate this (e.g. DBD::InterBase will segfault, DBD::Sybase
244   # won't start a transaction sanely, etc)
245   # We also can't use the accessor here, as it will trigger a fork/thread
246   # check, and resetting a cursor in a child is perfectly valid
247
248   my $self = shift;
249
250   # No need to care about failures here
251   try { local $SIG{__WARN__} = sub {}; $self->{sth}->finish } if (
252     $self->{sth} and ! try { ! $self->{sth}->FETCH('Active') }
253   );
254 }
255
256 =head1 FURTHER QUESTIONS?
257
258 Check the list of L<additional DBIC resources|DBIx::Class/GETTING HELP/SUPPORT>.
259
260 =head1 COPYRIGHT AND LICENSE
261
262 This module is free software L<copyright|DBIx::Class/COPYRIGHT AND LICENSE>
263 by the L<DBIx::Class (DBIC) authors|DBIx::Class/AUTHORS>. You can
264 redistribute it and/or modify it under the same terms as the
265 L<DBIx::Class library|DBIx::Class/COPYRIGHT AND LICENSE>.
266
267 =cut
268
269 1;