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