ResultSetColumn::func() now returns all results if called in list context
[dbsrgits/DBIx-Class-Historic.git] / lib / DBIx / Class / Storage.pm
1 package DBIx::Class::Storage;
2
3 use strict;
4 use warnings;
5
6 use base qw/DBIx::Class/;
7
8 use Scalar::Util qw/weaken/;
9 use Carp::Clan qw/^DBIx::Class/;
10 use IO::File;
11
12 __PACKAGE__->mk_group_accessors('simple' => qw/debug debugobj schema/);
13 __PACKAGE__->mk_group_accessors('inherited' => 'cursor_class');
14
15 __PACKAGE__->cursor_class('DBIx::Class::Cursor');
16
17 sub cursor { shift->cursor_class(@_); }
18
19 package # Hide from PAUSE
20     DBIx::Class::Storage::NESTED_ROLLBACK_EXCEPTION;
21
22 use overload '"' => sub {
23   'DBIx::Class::Storage::NESTED_ROLLBACK_EXCEPTION'
24 };
25
26 sub new {
27   my $class = shift;
28   my $self = {};
29   return bless $self, $class;
30 }
31
32 package DBIx::Class::Storage;
33
34 =head1 NAME
35
36 DBIx::Class::Storage - Generic Storage Handler
37
38 =head1 DESCRIPTION
39
40 A base implementation of common Storage methods.  For specific
41 information about L<DBI>-based storage, see L<DBIx::Class::Storage::DBI>.
42
43 =head1 METHODS
44
45 =head2 new
46
47 Arguments: $schema
48
49 Instantiates the Storage object.
50
51 =cut
52
53 sub new {
54   my ($self, $schema) = @_;
55
56   $self = ref $self if ref $self;
57
58   my $new = {};
59   bless $new, $self;
60
61   $new->set_schema($schema);
62   $new->debugobj(new DBIx::Class::Storage::Statistics());
63
64   #my $fh;
65
66   my $debug_env = $ENV{DBIX_CLASS_STORAGE_DBI_DEBUG}
67                   || $ENV{DBIC_TRACE};
68
69   $new->debug(1) if $debug_env;
70
71   $new;
72 }
73
74 =head2 set_schema
75
76 Used to reset the schema class or object which owns this
77 storage object, such as during L<DBIx::Class::Schema/clone>.
78
79 =cut
80
81 sub set_schema {
82   my ($self, $schema) = @_;
83   $self->schema($schema);
84   weaken($self->{schema}) if ref $self->{schema};
85 }
86
87 =head2 connected
88
89 Returns true if we have an open storage connection, false
90 if it is not (yet) open.
91
92 =cut
93
94 sub connected { die "Virtual method!" }
95
96 =head2 disconnect
97
98 Closes any open storage connection unconditionally.
99
100 =cut
101
102 sub disconnect { die "Virtual method!" }
103
104 =head2 ensure_connected
105
106 Initiate a connection to the storage if one isn't already open.
107
108 =cut
109
110 sub ensure_connected { die "Virtual method!" }
111
112 =head2 throw_exception
113
114 Throws an exception - croaks.
115
116 =cut
117
118 sub throw_exception {
119   my $self = shift;
120
121   $self->schema->throw_exception(@_) if $self->schema;
122   croak @_;
123 }
124
125 =head2 txn_do
126
127 =over 4
128
129 =item Arguments: C<$coderef>, @coderef_args?
130
131 =item Return Value: The return value of $coderef
132
133 =back
134
135 Executes C<$coderef> with (optional) arguments C<@coderef_args> atomically,
136 returning its result (if any). If an exception is caught, a rollback is issued
137 and the exception is rethrown. If the rollback fails, (i.e. throws an
138 exception) an exception is thrown that includes a "Rollback failed" message.
139
140 For example,
141
142   my $author_rs = $schema->resultset('Author')->find(1);
143   my @titles = qw/Night Day It/;
144
145   my $coderef = sub {
146     # If any one of these fails, the entire transaction fails
147     $author_rs->create_related('books', {
148       title => $_
149     }) foreach (@titles);
150
151     return $author->books;
152   };
153
154   my $rs;
155   eval {
156     $rs = $schema->txn_do($coderef);
157   };
158
159   if ($@) {                                  # Transaction failed
160     die "something terrible has happened!"   #
161       if ($@ =~ /Rollback failed/);          # Rollback failed
162
163     deal_with_failed_transaction();
164   }
165
166 In a nested transaction (calling txn_do() from within a txn_do() coderef) only
167 the outermost transaction will issue a L</txn_commit>, and txn_do() can be
168 called in void, scalar and list context and it will behave as expected.
169
170 Please note that all of the code in your coderef, including non-DBIx::Class
171 code, is part of a transaction.  This transaction may fail out halfway, or
172 it may get partially double-executed (in the case that our DB connection
173 failed halfway through the transaction, in which case we reconnect and
174 restart the txn).  Therefore it is best that any side-effects in your coderef
175 are idempotent (that is, can be re-executed multiple times and get the
176 same result), and that you check up on your side-effects in the case of
177 transaction failure.
178
179 =cut
180
181 sub txn_do {
182   my ($self, $coderef, @args) = @_;
183
184   ref $coderef eq 'CODE' or $self->throw_exception
185     ('$coderef must be a CODE reference');
186
187   my (@return_values, $return_value);
188
189   $self->txn_begin; # If this throws an exception, no rollback is needed
190
191   my $wantarray = wantarray; # Need to save this since the context
192                              # inside the eval{} block is independent
193                              # of the context that called txn_do()
194   eval {
195
196     # Need to differentiate between scalar/list context to allow for
197     # returning a list in scalar context to get the size of the list
198     if ($wantarray) {
199       # list context
200       @return_values = $coderef->(@args);
201     } elsif (defined $wantarray) {
202       # scalar context
203       $return_value = $coderef->(@args);
204     } else {
205       # void context
206       $coderef->(@args);
207     }
208     $self->txn_commit;
209   };
210
211   if ($@) {
212     my $error = $@;
213
214     eval {
215       $self->txn_rollback;
216     };
217
218     if ($@) {
219       my $rollback_error = $@;
220       my $exception_class = "DBIx::Class::Storage::NESTED_ROLLBACK_EXCEPTION";
221       $self->throw_exception($error)  # propagate nested rollback
222         if $rollback_error =~ /$exception_class/;
223
224       $self->throw_exception(
225         "Transaction aborted: $error. Rollback failed: ${rollback_error}"
226       );
227     } else {
228       $self->throw_exception($error); # txn failed but rollback succeeded
229     }
230   }
231
232   return $wantarray ? @return_values : $return_value;
233 }
234
235 =head2 txn_begin
236
237 Starts a transaction.
238
239 See the preferred L</txn_do> method, which allows for
240 an entire code block to be executed transactionally.
241
242 =cut
243
244 sub txn_begin { die "Virtual method!" }
245
246 =head2 txn_commit
247
248 Issues a commit of the current transaction.
249
250 =cut
251
252 sub txn_commit { die "Virtual method!" }
253
254 =head2 txn_rollback
255
256 Issues a rollback of the current transaction. A nested rollback will
257 throw a L<DBIx::Class::Storage::NESTED_ROLLBACK_EXCEPTION> exception,
258 which allows the rollback to propagate to the outermost transaction.
259
260 =cut
261
262 sub txn_rollback { die "Virtual method!" }
263
264 =head2 sql_maker
265
266 Returns a C<sql_maker> object - normally an object of class
267 C<DBIC::SQL::Abstract>.
268
269 =cut
270
271 sub sql_maker { die "Virtual method!" }
272
273 =head2 debug
274
275 Causes trace information to be emitted on the C<debugobj> object.
276 (or C<STDERR> if C<debugobj> has not specifically been set).
277
278 This is the equivalent to setting L</DBIC_TRACE> in your
279 shell environment.
280
281 =head2 debugfh
282
283 Set or retrieve the filehandle used for trace/debug output.  This should be
284 an IO::Handle compatible ojbect (only the C<print> method is used.  Initially
285 set to be STDERR - although see information on the
286 L<DBIC_TRACE> environment variable.
287
288 =cut
289
290 sub debugfh {
291     my $self = shift;
292
293     if ($self->debugobj->can('debugfh')) {
294         return $self->debugobj->debugfh(@_);
295     }
296 }
297
298 =head2 debugobj
299
300 Sets or retrieves the object used for metric collection. Defaults to an instance
301 of L<DBIx::Class::Storage::Statistics> that is compatible with the original
302 method of using a coderef as a callback.  See the aforementioned Statistics
303 class for more information.
304
305 =head2 debugcb
306
307 Sets a callback to be executed each time a statement is run; takes a sub
308 reference.  Callback is executed as $sub->($op, $info) where $op is
309 SELECT/INSERT/UPDATE/DELETE and $info is what would normally be printed.
310
311 See L<debugobj> for a better way.
312
313 =cut
314
315 sub debugcb {
316     my $self = shift;
317
318     if ($self->debugobj->can('callback')) {
319         return $self->debugobj->callback(@_);
320     }
321 }
322
323 =head2 cursor_class
324
325 The cursor class for this Storage object.
326
327 =cut
328
329 =head2 deploy
330
331 Deploy the tables to storage (CREATE TABLE and friends in a SQL-based
332 Storage class). This would normally be called through
333 L<DBIx::Class::Schema/deploy>.
334
335 =cut
336
337 sub deploy { die "Virtual method!" }
338
339 =head2 connect_info
340
341 The arguments of C<connect_info> are always a single array reference,
342 and are Storage-handler specific.
343
344 This is normally accessed via L<DBIx::Class::Schema/connection>, which
345 encapsulates its argument list in an arrayref before calling
346 C<connect_info> here.
347
348 =cut
349
350 sub connect_info { die "Virtual method!" }
351
352 =head2 select
353
354 Handle a select statement.
355
356 =cut
357
358 sub select { die "Virtual method!" }
359
360 =head2 insert
361
362 Handle an insert statement.
363
364 =cut
365
366 sub insert { die "Virtual method!" }
367
368 =head2 update
369
370 Handle an update statement.
371
372 =cut
373
374 sub update { die "Virtual method!" }
375
376 =head2 delete
377
378 Handle a delete statement.
379
380 =cut
381
382 sub delete { die "Virtual method!" }
383
384 =head2 select_single
385
386 Performs a select, fetch and return of data - handles a single row
387 only.
388
389 =cut
390
391 sub select_single { die "Virtual method!" }
392
393 =head2 columns_info_for
394
395 Returns metadata for the given source's columns.  This
396 is *deprecated*, and will be removed before 1.0.  You should
397 be specifying the metadata yourself if you need it.
398
399 =cut
400
401 sub columns_info_for { die "Virtual method!" }
402
403 =head1 ENVIRONMENT VARIABLES
404
405 =head2 DBIC_TRACE
406
407 If C<DBIC_TRACE> is set then trace information
408 is produced (as when the L<debug> method is set).
409
410 If the value is of the form C<1=/path/name> then the trace output is
411 written to the file C</path/name>.
412
413 This environment variable is checked when the storage object is first
414 created (when you call connect on your schema).  So, run-time changes 
415 to this environment variable will not take effect unless you also 
416 re-connect on your schema.
417
418 =head2 DBIX_CLASS_STORAGE_DBI_DEBUG
419
420 Old name for DBIC_TRACE
421
422 =head1 AUTHORS
423
424 Matt S. Trout <mst@shadowcatsystems.co.uk>
425
426 Andy Grundman <andy@hybridized.org>
427
428 =head1 LICENSE
429
430 You may distribute this code under the same terms as Perl itself.
431
432 =cut
433
434 1;