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