Redo badly named constant folding arg introduced in 8d73fcd4
[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 {
10   package # Hide from PAUSE
11     DBIx::Class::Storage::NESTED_ROLLBACK_EXCEPTION;
12   use base 'DBIx::Class::Exception';
13 }
14
15 use DBIx::Class::Carp;
16 use DBIx::Class::Storage::BlockRunner;
17 use Scalar::Util qw/blessed weaken/;
18 use DBIx::Class::Storage::TxnScopeGuard;
19 use Try::Tiny;
20 use namespace::clean;
21
22 __PACKAGE__->mk_group_accessors(simple => qw/debug schema transaction_depth auto_savepoint savepoints/);
23 __PACKAGE__->mk_group_accessors(component_class => 'cursor_class');
24
25 __PACKAGE__->cursor_class('DBIx::Class::Cursor');
26
27 sub cursor { shift->cursor_class(@_); }
28
29 =head1 NAME
30
31 DBIx::Class::Storage - Generic Storage Handler
32
33 =head1 DESCRIPTION
34
35 A base implementation of common Storage methods.  For specific
36 information about L<DBI>-based storage, see L<DBIx::Class::Storage::DBI>.
37
38 =head1 METHODS
39
40 =head2 new
41
42 Arguments: $schema
43
44 Instantiates the Storage object.
45
46 =cut
47
48 sub new {
49   my ($self, $schema) = @_;
50
51   $self = ref $self if ref $self;
52
53   my $new = bless( {
54     transaction_depth => 0,
55     savepoints => [],
56   }, $self);
57
58   $new->set_schema($schema);
59   $new->debug(1)
60     if $ENV{DBIX_CLASS_STORAGE_DBI_DEBUG} || $ENV{DBIC_TRACE};
61
62   $new;
63 }
64
65 =head2 set_schema
66
67 Used to reset the schema class or object which owns this
68 storage object, such as during L<DBIx::Class::Schema/clone>.
69
70 =cut
71
72 sub set_schema {
73   my ($self, $schema) = @_;
74   $self->schema($schema);
75   weaken $self->{schema} if ref $self->{schema};
76 }
77
78 =head2 connected
79
80 Returns true if we have an open storage connection, false
81 if it is not (yet) open.
82
83 =cut
84
85 sub connected { die "Virtual method!" }
86
87 =head2 disconnect
88
89 Closes any open storage connection unconditionally.
90
91 =cut
92
93 sub disconnect { die "Virtual method!" }
94
95 =head2 ensure_connected
96
97 Initiate a connection to the storage if one isn't already open.
98
99 =cut
100
101 sub ensure_connected { die "Virtual method!" }
102
103 =head2 throw_exception
104
105 Throws an exception - croaks.
106
107 =cut
108
109 sub throw_exception {
110   my $self = shift;
111
112   if (ref $self and $self->schema) {
113     $self->schema->throw_exception(@_);
114   }
115   else {
116     DBIx::Class::Exception->throw(@_);
117   }
118 }
119
120 =head2 txn_do
121
122 =over 4
123
124 =item Arguments: C<$coderef>, @coderef_args?
125
126 =item Return Value: The return value of $coderef
127
128 =back
129
130 Executes C<$coderef> with (optional) arguments C<@coderef_args> atomically,
131 returning its result (if any). If an exception is caught, a rollback is issued
132 and the exception is rethrown. If the rollback fails, (i.e. throws an
133 exception) an exception is thrown that includes a "Rollback failed" message.
134
135 For example,
136
137   my $author_rs = $schema->resultset('Author')->find(1);
138   my @titles = qw/Night Day It/;
139
140   my $coderef = sub {
141     # If any one of these fails, the entire transaction fails
142     $author_rs->create_related('books', {
143       title => $_
144     }) foreach (@titles);
145
146     return $author->books;
147   };
148
149   my $rs;
150   try {
151     $rs = $schema->txn_do($coderef);
152   } catch {
153     my $error = shift;
154     # Transaction failed
155     die "something terrible has happened!"
156       if ($error =~ /Rollback failed/);          # Rollback failed
157
158     deal_with_failed_transaction();
159   };
160
161 In a nested transaction (calling txn_do() from within a txn_do() coderef) only
162 the outermost transaction will issue a L</txn_commit>, and txn_do() can be
163 called in void, scalar and list context and it will behave as expected.
164
165 Please note that all of the code in your coderef, including non-DBIx::Class
166 code, is part of a transaction.  This transaction may fail out halfway, or
167 it may get partially double-executed (in the case that our DB connection
168 failed halfway through the transaction, in which case we reconnect and
169 restart the txn).  Therefore it is best that any side-effects in your coderef
170 are idempotent (that is, can be re-executed multiple times and get the
171 same result), and that you check up on your side-effects in the case of
172 transaction failure.
173
174 =cut
175
176 sub txn_do {
177   my $self = shift;
178
179   DBIx::Class::Storage::BlockRunner->new(
180     storage => $self,
181     wrap_txn => 1,
182     retry_handler => sub {
183       $_[0]->failed_attempt_count == 1
184         and
185       ! $_[0]->storage->connected
186     },
187   )->run(@_);
188 }
189
190 =head2 txn_begin
191
192 Starts a transaction.
193
194 See the preferred L</txn_do> method, which allows for
195 an entire code block to be executed transactionally.
196
197 =cut
198
199 sub txn_begin {
200   my $self = shift;
201
202   if($self->transaction_depth == 0) {
203     $self->debugobj->txn_begin()
204       if $self->debug;
205     $self->_exec_txn_begin;
206   }
207   elsif ($self->auto_savepoint) {
208     $self->svp_begin;
209   }
210   $self->{transaction_depth}++;
211
212 }
213
214 =head2 txn_commit
215
216 Issues a commit of the current transaction.
217
218 It does I<not> perform an actual storage commit unless there's a DBIx::Class
219 transaction currently in effect (i.e. you called L</txn_begin>).
220
221 =cut
222
223 sub txn_commit {
224   my $self = shift;
225
226   if ($self->transaction_depth == 1) {
227     $self->debugobj->txn_commit() if $self->debug;
228     $self->_exec_txn_commit;
229     $self->{transaction_depth}--;
230     $self->savepoints([]);
231   }
232   elsif($self->transaction_depth > 1) {
233     $self->{transaction_depth}--;
234     $self->svp_release if $self->auto_savepoint;
235   }
236   else {
237     $self->throw_exception( 'Refusing to commit without a started transaction' );
238   }
239 }
240
241 =head2 txn_rollback
242
243 Issues a rollback of the current transaction. A nested rollback will
244 throw a L<DBIx::Class::Storage::NESTED_ROLLBACK_EXCEPTION> exception,
245 which allows the rollback to propagate to the outermost transaction.
246
247 =cut
248
249 sub txn_rollback {
250   my $self = shift;
251
252   if ($self->transaction_depth == 1) {
253     $self->debugobj->txn_rollback() if $self->debug;
254     $self->_exec_txn_rollback;
255     $self->{transaction_depth}--;
256     $self->savepoints([]);
257   }
258   elsif ($self->transaction_depth > 1) {
259     $self->{transaction_depth}--;
260
261     if ($self->auto_savepoint) {
262       $self->svp_rollback;
263       $self->svp_release;
264     }
265     else {
266       DBIx::Class::Storage::NESTED_ROLLBACK_EXCEPTION->throw(
267         "A txn_rollback in nested transaction is ineffective! (depth $self->{transaction_depth})"
268       );
269     }
270   }
271   else {
272     $self->throw_exception( 'Refusing to roll back without a started transaction' );
273   }
274 }
275
276 =head2 svp_begin
277
278 Arguments: $savepoint_name?
279
280 Created a new savepoint using the name provided as argument. If no name
281 is provided, a random name will be used.
282
283 =cut
284
285 sub svp_begin {
286   my ($self, $name) = @_;
287
288   $self->throw_exception ("You can't use savepoints outside a transaction")
289     unless $self->transaction_depth;
290
291   my $exec = $self->can('_exec_svp_begin')
292     or $self->throw_exception ("Your Storage implementation doesn't support savepoints");
293
294   $name = $self->_svp_generate_name
295     unless defined $name;
296
297   push @{ $self->{savepoints} }, $name;
298
299   $self->debugobj->svp_begin($name) if $self->debug;
300
301   $exec->($self, $name);
302 }
303
304 sub _svp_generate_name {
305   my ($self) = @_;
306   return 'savepoint_'.scalar(@{ $self->{'savepoints'} });
307 }
308
309
310 =head2 svp_release
311
312 Arguments: $savepoint_name?
313
314 Release the savepoint provided as argument. If none is provided,
315 release the savepoint created most recently. This will implicitly
316 release all savepoints created after the one explicitly released as well.
317
318 =cut
319
320 sub svp_release {
321   my ($self, $name) = @_;
322
323   $self->throw_exception ("You can't use savepoints outside a transaction")
324     unless $self->transaction_depth;
325
326   my $exec = $self->can('_exec_svp_release')
327     or $self->throw_exception ("Your Storage implementation doesn't support savepoints");
328
329   if (defined $name) {
330     my @stack = @{ $self->savepoints };
331     my $svp;
332
333     do { $svp = pop @stack } until $svp eq $name;
334
335     $self->throw_exception ("Savepoint '$name' does not exist")
336       unless $svp;
337
338     $self->savepoints(\@stack); # put back what's left
339   }
340   else {
341     $name = pop @{ $self->savepoints }
342       or $self->throw_exception('No savepoints to release');;
343   }
344
345   $self->debugobj->svp_release($name) if $self->debug;
346
347   $exec->($self, $name);
348 }
349
350 =head2 svp_rollback
351
352 Arguments: $savepoint_name?
353
354 Rollback to the savepoint provided as argument. If none is provided,
355 rollback to the savepoint created most recently. This will implicitly
356 release all savepoints created after the savepoint we rollback to.
357
358 =cut
359
360 sub svp_rollback {
361   my ($self, $name) = @_;
362
363   $self->throw_exception ("You can't use savepoints outside a transaction")
364     unless $self->transaction_depth;
365
366   my $exec = $self->can('_exec_svp_rollback')
367     or $self->throw_exception ("Your Storage implementation doesn't support savepoints");
368
369   if (defined $name) {
370     my @stack = @{ $self->savepoints };
371     my $svp;
372
373     # a rollback doesn't remove the named savepoint,
374     # only everything after it
375     while (@stack and $stack[-1] ne $name) {
376       pop @stack
377     };
378
379     $self->throw_exception ("Savepoint '$name' does not exist")
380       unless @stack;
381
382     $self->savepoints(\@stack); # put back what's left
383   }
384   else {
385     $name = $self->savepoints->[-1]
386       or $self->throw_exception('No savepoints to rollback');;
387   }
388
389   $self->debugobj->svp_rollback($name) if $self->debug;
390
391   $exec->($self, $name);
392 }
393
394 =head2 txn_scope_guard
395
396 An alternative way of transaction handling based on
397 L<DBIx::Class::Storage::TxnScopeGuard>:
398
399  my $txn_guard = $storage->txn_scope_guard;
400
401  $result->col1("val1");
402  $result->update;
403
404  $txn_guard->commit;
405
406 If an exception occurs, or the guard object otherwise leaves the scope
407 before C<< $txn_guard->commit >> is called, the transaction will be rolled
408 back by an explicit L</txn_rollback> call. In essence this is akin to
409 using a L</txn_begin>/L</txn_commit> pair, without having to worry
410 about calling L</txn_rollback> at the right places. Note that since there
411 is no defined code closure, there will be no retries and other magic upon
412 database disconnection. If you need such functionality see L</txn_do>.
413
414 =cut
415
416 sub txn_scope_guard {
417   return DBIx::Class::Storage::TxnScopeGuard->new($_[0]);
418 }
419
420 =head2 sql_maker
421
422 Returns a C<sql_maker> object - normally an object of class
423 C<DBIx::Class::SQLMaker>.
424
425 =cut
426
427 sub sql_maker { die "Virtual method!" }
428
429 =head2 debug
430
431 Causes trace information to be emitted on the L</debugobj> object.
432 (or C<STDERR> if L</debugobj> has not specifically been set).
433
434 This is the equivalent to setting L</DBIC_TRACE> in your
435 shell environment.
436
437 =head2 debugfh
438
439 An opportunistic proxy to L<< ->debugobj->debugfh(@_)
440 |DBIx::Class::Storage::Statistics/debugfh >>
441 If the currently set L</debugobj> does not have a L</debugfh> method, caling
442 this is a no-op.
443
444 =cut
445
446 sub debugfh {
447     my $self = shift;
448
449     if ($self->debugobj->can('debugfh')) {
450         return $self->debugobj->debugfh(@_);
451     }
452 }
453
454 =head2 debugobj
455
456 Sets or retrieves the object used for metric collection. Defaults to an instance
457 of L<DBIx::Class::Storage::Statistics> that is compatible with the original
458 method of using a coderef as a callback.  See the aforementioned Statistics
459 class for more information.
460
461 =cut
462
463 sub debugobj {
464   my $self = shift;
465
466   if (@_) {
467     return $self->{debugobj} = $_[0];
468   }
469
470   $self->{debugobj} ||= do {
471     if (my $profile = $ENV{DBIC_TRACE_PROFILE}) {
472       require DBIx::Class::Storage::Debug::PrettyPrint;
473       my @pp_args;
474
475       if ($profile =~ /^\.?\//) {
476         require Config::Any;
477
478         my $cfg = try {
479           Config::Any->load_files({ files => [$profile], use_ext => 1 });
480         } catch {
481           # sanitize the error message a bit
482           $_ =~ s/at \s+ .+ Storage\.pm \s line \s \d+ $//x;
483           $self->throw_exception("Failure processing \$ENV{DBIC_TRACE_PROFILE}: $_");
484         };
485
486         @pp_args = values %{$cfg->[0]};
487       }
488       else {
489         @pp_args = { profile => $profile };
490       }
491
492       # FIXME - FRAGILE
493       # Hash::Merge is a sorry piece of shit and tramples all over $@
494       # *without* throwing an exception
495       # This is a rather serious problem in the debug codepath
496       # Insulate the condition here with a try{} until a review of
497       # DBIx::Class::Storage::Debug::PrettyPrint takes place
498       # we do rethrow the error unconditionally, the only reason
499       # to try{} is to preserve the precise state of $@ (down
500       # to the scalar (if there is one) address level)
501       #
502       # Yes I am aware this is fragile and TxnScopeGuard needs
503       # a better fix. This is another yak to shave... :(
504       try {
505         DBIx::Class::Storage::Debug::PrettyPrint->new(@pp_args);
506       } catch {
507         $self->throw_exception($_);
508       }
509     }
510     else {
511       require DBIx::Class::Storage::Statistics;
512       DBIx::Class::Storage::Statistics->new
513     }
514   };
515 }
516
517 =head2 debugcb
518
519 Sets a callback to be executed each time a statement is run; takes a sub
520 reference.  Callback is executed as $sub->($op, $info) where $op is
521 SELECT/INSERT/UPDATE/DELETE and $info is what would normally be printed.
522
523 See L</debugobj> for a better way.
524
525 =cut
526
527 sub debugcb {
528     my $self = shift;
529
530     if ($self->debugobj->can('callback')) {
531         return $self->debugobj->callback(@_);
532     }
533 }
534
535 =head2 cursor_class
536
537 The cursor class for this Storage object.
538
539 =cut
540
541 =head2 deploy
542
543 Deploy the tables to storage (CREATE TABLE and friends in a SQL-based
544 Storage class). This would normally be called through
545 L<DBIx::Class::Schema/deploy>.
546
547 =cut
548
549 sub deploy { die "Virtual method!" }
550
551 =head2 connect_info
552
553 The arguments of C<connect_info> are always a single array reference,
554 and are Storage-handler specific.
555
556 This is normally accessed via L<DBIx::Class::Schema/connection>, which
557 encapsulates its argument list in an arrayref before calling
558 C<connect_info> here.
559
560 =cut
561
562 sub connect_info { die "Virtual method!" }
563
564 =head2 select
565
566 Handle a select statement.
567
568 =cut
569
570 sub select { die "Virtual method!" }
571
572 =head2 insert
573
574 Handle an insert statement.
575
576 =cut
577
578 sub insert { die "Virtual method!" }
579
580 =head2 update
581
582 Handle an update statement.
583
584 =cut
585
586 sub update { die "Virtual method!" }
587
588 =head2 delete
589
590 Handle a delete statement.
591
592 =cut
593
594 sub delete { die "Virtual method!" }
595
596 =head2 select_single
597
598 Performs a select, fetch and return of data - handles a single row
599 only.
600
601 =cut
602
603 sub select_single { die "Virtual method!" }
604
605 =head2 columns_info_for
606
607 Returns metadata for the given source's columns.  This
608 is *deprecated*, and will be removed before 1.0.  You should
609 be specifying the metadata yourself if you need it.
610
611 =cut
612
613 sub columns_info_for { die "Virtual method!" }
614
615 =head1 ENVIRONMENT VARIABLES
616
617 =head2 DBIC_TRACE
618
619 If C<DBIC_TRACE> is set then trace information
620 is produced (as when the L</debug> method is set).
621
622 If the value is of the form C<1=/path/name> then the trace output is
623 written to the file C</path/name>.
624
625 This environment variable is checked when the storage object is first
626 created (when you call connect on your schema).  So, run-time changes
627 to this environment variable will not take effect unless you also
628 re-connect on your schema.
629
630 =head2 DBIC_TRACE_PROFILE
631
632 If C<DBIC_TRACE_PROFILE> is set, L<DBIx::Class::Storage::Debug::PrettyPrint>
633 will be used to format the output from C<DBIC_TRACE>.  The value it
634 is set to is the C<profile> that it will be used.  If the value is a
635 filename the file is read with L<Config::Any> and the results are
636 used as the configuration for tracing.  See L<SQL::Abstract::Tree/new>
637 for what that structure should look like.
638
639 =head2 DBIX_CLASS_STORAGE_DBI_DEBUG
640
641 Old name for DBIC_TRACE
642
643 =head1 SEE ALSO
644
645 L<DBIx::Class::Storage::DBI> - reference storage implementation using
646 SQL::Abstract and DBI.
647
648 =head1 FURTHER QUESTIONS?
649
650 Check the list of L<additional DBIC resources|DBIx::Class/GETTING HELP/SUPPORT>.
651
652 =head1 COPYRIGHT AND LICENSE
653
654 This module is free software L<copyright|DBIx::Class/COPYRIGHT AND LICENSE>
655 by the L<DBIx::Class (DBIC) authors|DBIx::Class/AUTHORS>. You can
656 redistribute it and/or modify it under the same terms as the
657 L<DBIx::Class library|DBIx::Class/COPYRIGHT AND LICENSE>.
658
659 =cut
660
661 1;