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