Add an explicit Sub::Quote dep in ::_Util
[dbsrgits/DBIx-Class-Historic.git] / lib / DBIx / Class / Storage.pm
CommitLineData
4012acd8 1package DBIx::Class::Storage;
a62cf8d4 2
3use strict;
4use warnings;
5
046ad905 6use base qw/DBIx::Class/;
2ad62d97 7use mro 'c3';
046ad905 8
90d7422f 9{
10 package # Hide from PAUSE
11 DBIx::Class::Storage::NESTED_ROLLBACK_EXCEPTION;
12 use base 'DBIx::Class::Exception';
13}
14
15use DBIx::Class::Carp;
9345b14c 16use DBIx::Class::Storage::BlockRunner;
90d7422f 17use Scalar::Util qw/blessed weaken/;
1bc193ac 18use DBIx::Class::Storage::TxnScopeGuard;
e5053694 19use DBIx::Class::_Util qw( dbic_internal_try fail_on_internal_call );
f43ea814 20use Try::Tiny;
fd323bf1 21use namespace::clean;
046ad905 22
90d7422f 23__PACKAGE__->mk_group_accessors(simple => qw/debug schema transaction_depth auto_savepoint savepoints/);
24__PACKAGE__->mk_group_accessors(component_class => 'cursor_class');
e4eb8ee1 25
26__PACKAGE__->cursor_class('DBIx::Class::Cursor');
27
e5053694 28sub cursor {
29 DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and fail_on_internal_call;
30 shift->cursor_class(@_);
31}
046ad905 32
046ad905 33=head1 NAME
34
35DBIx::Class::Storage - Generic Storage Handler
36
37=head1 DESCRIPTION
38
39A base implementation of common Storage methods. For specific
40information about L<DBI>-based storage, see L<DBIx::Class::Storage::DBI>.
41
42=head1 METHODS
43
44=head2 new
45
46Arguments: $schema
47
48Instantiates the Storage object.
49
50=cut
51
52sub new {
53 my ($self, $schema) = @_;
54
55 $self = ref $self if ref $self;
56
90d7422f 57 my $new = bless( {
90d7422f 58 savepoints => [],
59 }, $self);
046ad905 60
61 $new->set_schema($schema);
4d753fb8 62 $new->debug(1)
63 if $ENV{DBIX_CLASS_STORAGE_DBI_DEBUG} || $ENV{DBIC_TRACE};
046ad905 64
65 $new;
66}
67
68=head2 set_schema
69
70Used to reset the schema class or object which owns this
71storage object, such as during L<DBIx::Class::Schema/clone>.
72
73=cut
74
75sub set_schema {
76 my ($self, $schema) = @_;
77 $self->schema($schema);
6298a324 78 weaken $self->{schema} if ref $self->{schema};
046ad905 79}
80
81=head2 connected
82
83Returns true if we have an open storage connection, false
84if it is not (yet) open.
85
86=cut
87
a62cf8d4 88sub connected { die "Virtual method!" }
046ad905 89
90=head2 disconnect
91
92Closes any open storage connection unconditionally.
93
94=cut
95
96sub disconnect { die "Virtual method!" }
97
98=head2 ensure_connected
99
100Initiate a connection to the storage if one isn't already open.
101
102=cut
103
a62cf8d4 104sub ensure_connected { die "Virtual method!" }
046ad905 105
106=head2 throw_exception
107
108Throws an exception - croaks.
109
110=cut
111
112sub throw_exception {
113 my $self = shift;
114
2a2a7b23 115 if (ref $self and $self->schema) {
1a58752c 116 $self->schema->throw_exception(@_);
117 }
118 else {
119 DBIx::Class::Exception->throw(@_);
120 }
046ad905 121}
a62cf8d4 122
4012acd8 123=head2 txn_do
a62cf8d4 124
4012acd8 125=over 4
a62cf8d4 126
4012acd8 127=item Arguments: C<$coderef>, @coderef_args?
a62cf8d4 128
4012acd8 129=item Return Value: The return value of $coderef
130
131=back
132
133Executes C<$coderef> with (optional) arguments C<@coderef_args> atomically,
134returning its result (if any). If an exception is caught, a rollback is issued
135and the exception is rethrown. If the rollback fails, (i.e. throws an
136exception) an exception is thrown that includes a "Rollback failed" message.
137
138For 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;
20674fcd 153 try {
4012acd8 154 $rs = $schema->txn_do($coderef);
20674fcd 155 } catch {
6b89ee0b 156 my $error = shift;
20674fcd 157 # Transaction failed
90d7422f 158 die "something terrible has happened!"
6b89ee0b 159 if ($error =~ /Rollback failed/); # Rollback failed
4012acd8 160
161 deal_with_failed_transaction();
20674fcd 162 };
4012acd8 163
164In a nested transaction (calling txn_do() from within a txn_do() coderef) only
165the outermost transaction will issue a L</txn_commit>, and txn_do() can be
166called in void, scalar and list context and it will behave as expected.
167
05075aee 168Please note that all of the code in your coderef, including non-DBIx::Class
169code, is part of a transaction. This transaction may fail out halfway, or
170it may get partially double-executed (in the case that our DB connection
171failed halfway through the transaction, in which case we reconnect and
172restart the txn). Therefore it is best that any side-effects in your coderef
173are idempotent (that is, can be re-executed multiple times and get the
174same result), and that you check up on your side-effects in the case of
175transaction failure.
6500d50f 176
4012acd8 177=cut
178
179sub txn_do {
38ed54cd 180 my $self = shift;
4012acd8 181
9345b14c 182 DBIx::Class::Storage::BlockRunner->new(
183 storage => $self,
9345b14c 184 wrap_txn => 1,
7d534e68 185 retry_handler => sub {
186 $_[0]->failed_attempt_count == 1
187 and
188 ! $_[0]->storage->connected
189 },
190 )->run(@_);
a62cf8d4 191}
192
046ad905 193=head2 txn_begin
194
195Starts a transaction.
196
197See the preferred L</txn_do> method, which allows for
198an entire code block to be executed transactionally.
199
200=cut
201
90d7422f 202sub 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}
046ad905 216
217=head2 txn_commit
218
219Issues a commit of the current transaction.
220
be01f1be 221It does I<not> perform an actual storage commit unless there's a DBIx::Class
222transaction currently in effect (i.e. you called L</txn_begin>).
223
046ad905 224=cut
225
90d7422f 226sub 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}--;
398215b1 233 $self->savepoints([]);
90d7422f 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}
046ad905 243
244=head2 txn_rollback
245
246Issues a rollback of the current transaction. A nested rollback will
247throw a L<DBIx::Class::Storage::NESTED_ROLLBACK_EXCEPTION> exception,
248which allows the rollback to propagate to the outermost transaction.
249
250=cut
251
90d7422f 252sub txn_rollback {
253 my $self = shift;
254
255 if ($self->transaction_depth == 1) {
256 $self->debugobj->txn_rollback() if $self->debug;
90d7422f 257 $self->{transaction_depth}--;
729656c5 258
259 # in case things get really hairy - just disconnect
ddcc02d1 260 dbic_internal_try { $self->_exec_txn_rollback; 1 } or do {
729656c5 261 my $rollback_error = $@;
262
263 # whatever happens, too low down the stack to care
264 # FIXME - revisit if stackable exceptions become a thing
ddcc02d1 265 dbic_internal_try { $self->disconnect };
729656c5 266
267 die $rollback_error;
268 };
269
398215b1 270 $self->savepoints([]);
90d7422f 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}
046ad905 289
84efb6d7 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
295sub __delicate_rollback {
296 my $self = shift;
297
298 if (
729656c5 299 ( $self->transaction_depth || 0 ) > 1
84efb6d7 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
ddcc02d1 317 my @args = @_;
84efb6d7 318 my $rbe;
319
ddcc02d1 320 dbic_internal_try {
321 $self->txn_rollback; 1
322 }
323 catch {
84efb6d7 324
ddcc02d1 325 $rbe = $_;
84efb6d7 326
327 # we were passed an existing exception to augment (think DESTROY stacks etc)
ddcc02d1 328 if (@args) {
329 my ($exception) = @args;
84efb6d7 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 }
ddcc02d1 377 };
84efb6d7 378
379 return $rbe;
380}
381
adb3554a 382=head2 svp_begin
383
360dc8a5 384Arguments: $savepoint_name?
adb3554a 385
360dc8a5 386Created a new savepoint using the name provided as argument. If no name
387is provided, a random name will be used.
adb3554a 388
389=cut
390
90d7422f 391sub 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
410sub _svp_generate_name {
411 my ($self) = @_;
412 return 'savepoint_'.scalar(@{ $self->{'savepoints'} });
413}
414
adb3554a 415
416=head2 svp_release
417
360dc8a5 418Arguments: $savepoint_name?
adb3554a 419
360dc8a5 420Release the savepoint provided as argument. If none is provided,
421release the savepoint created most recently. This will implicitly
422release all savepoints created after the one explicitly released as well.
adb3554a 423
424=cut
425
90d7422f 426sub 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 };
f5f0cb1d 437 my $svp = '';
90d7422f 438
f5f0cb1d 439 while( $svp ne $name ) {
90d7422f 440
f5f0cb1d 441 $self->throw_exception ("Savepoint '$name' does not exist")
442 unless @stack;
443
444 $svp = pop @stack;
445 }
90d7422f 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}
adb3554a 458
459=head2 svp_rollback
460
360dc8a5 461Arguments: $savepoint_name?
adb3554a 462
360dc8a5 463Rollback to the savepoint provided as argument. If none is provided,
464rollback to the savepoint created most recently. This will implicitly
465release all savepoints created after the savepoint we rollback to.
adb3554a 466
467=cut
468
90d7422f 469sub 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}
adb3554a 502
11544e1d 503=head2 txn_scope_guard
3b7f3eac 504
11544e1d 505An alternative way of transaction handling based on
506L<DBIx::Class::Storage::TxnScopeGuard>:
1bc193ac 507
11544e1d 508 my $txn_guard = $storage->txn_scope_guard;
89028f42 509
47d7b769 510 $result->col1("val1");
511 $result->update;
89028f42 512
11544e1d 513 $txn_guard->commit;
89028f42 514
11544e1d 515If an exception occurs, or the guard object otherwise leaves the scope
516before C<< $txn_guard->commit >> is called, the transaction will be rolled
517back by an explicit L</txn_rollback> call. In essence this is akin to
518using a L</txn_begin>/L</txn_commit> pair, without having to worry
519about calling L</txn_rollback> at the right places. Note that since there
520is no defined code closure, there will be no retries and other magic upon
521database disconnection. If you need such functionality see L</txn_do>.
1bc193ac 522
523=cut
524
525sub txn_scope_guard {
526 return DBIx::Class::Storage::TxnScopeGuard->new($_[0]);
527}
528
046ad905 529=head2 sql_maker
530
531Returns a C<sql_maker> object - normally an object of class
d5dedbd6 532C<DBIx::Class::SQLMaker>.
046ad905 533
534=cut
535
536sub sql_maker { die "Virtual method!" }
537
538=head2 debug
539
f92a9d79 540Causes trace information to be emitted on the L</debugobj> object.
541(or C<STDERR> if L</debugobj> has not specifically been set).
046ad905 542
543This is the equivalent to setting L</DBIC_TRACE> in your
544shell environment.
545
546=head2 debugfh
547
4d93345c 548An opportunistic proxy to L<< ->debugobj->debugfh(@_)
549|DBIx::Class::Storage::Statistics/debugfh >>
550If the currently set L</debugobj> does not have a L</debugfh> method, caling
551this is a no-op.
046ad905 552
553=cut
554
555sub debugfh {
556 my $self = shift;
557
558 if ($self->debugobj->can('debugfh')) {
559 return $self->debugobj->debugfh(@_);
560 }
561}
562
563=head2 debugobj
564
565Sets or retrieves the object used for metric collection. Defaults to an instance
566of L<DBIx::Class::Storage::Statistics> that is compatible with the original
567method of using a coderef as a callback. See the aforementioned Statistics
568class for more information.
569
4d753fb8 570=cut
571
572sub 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;
6e102c8f 582 my @pp_args;
583
4d753fb8 584 if ($profile =~ /^\.?\//) {
0dd1b736 585
18a2903b 586 require DBIx::Class::Optional::Dependencies;
0dd1b736 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 }
4d753fb8 590
ddcc02d1 591 my $cfg = dbic_internal_try {
4d753fb8 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
6e102c8f 599 @pp_args = values %{$cfg->[0]};
4d753fb8 600 }
601 else {
6e102c8f 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... :(
ddcc02d1 617 dbic_internal_try {
6e102c8f 618 DBIx::Class::Storage::Debug::PrettyPrint->new(@pp_args);
619 } catch {
620 $self->throw_exception($_);
4d753fb8 621 }
622 }
623 else {
624 require DBIx::Class::Storage::Statistics;
625 DBIx::Class::Storage::Statistics->new
626 }
627 };
628}
629
046ad905 630=head2 debugcb
631
632Sets a callback to be executed each time a statement is run; takes a sub
633reference. Callback is executed as $sub->($op, $info) where $op is
634SELECT/INSERT/UPDATE/DELETE and $info is what would normally be printed.
635
f92a9d79 636See L</debugobj> for a better way.
046ad905 637
638=cut
639
640sub debugcb {
641 my $self = shift;
642
643 if ($self->debugobj->can('callback')) {
644 return $self->debugobj->callback(@_);
645 }
646}
647
e4eb8ee1 648=head2 cursor_class
046ad905 649
650The cursor class for this Storage object.
651
652=cut
653
046ad905 654=head2 deploy
655
656Deploy the tables to storage (CREATE TABLE and friends in a SQL-based
657Storage class). This would normally be called through
658L<DBIx::Class::Schema/deploy>.
659
660=cut
661
662sub deploy { die "Virtual method!" }
663
a3eaff0e 664=head2 connect_info
665
666The arguments of C<connect_info> are always a single array reference,
667and are Storage-handler specific.
668
669This is normally accessed via L<DBIx::Class::Schema/connection>, which
670encapsulates its argument list in an arrayref before calling
671C<connect_info> here.
672
673=cut
674
046ad905 675sub connect_info { die "Virtual method!" }
a3eaff0e 676
677=head2 select
678
679Handle a select statement.
680
681=cut
682
683sub select { die "Virtual method!" }
684
685=head2 insert
686
687Handle an insert statement.
688
689=cut
690
046ad905 691sub insert { die "Virtual method!" }
a3eaff0e 692
693=head2 update
694
695Handle an update statement.
696
697=cut
698
046ad905 699sub update { die "Virtual method!" }
a3eaff0e 700
701=head2 delete
702
703Handle a delete statement.
704
705=cut
706
046ad905 707sub delete { die "Virtual method!" }
a3eaff0e 708
709=head2 select_single
710
711Performs a select, fetch and return of data - handles a single row
712only.
713
714=cut
715
046ad905 716sub select_single { die "Virtual method!" }
a3eaff0e 717
718=head2 columns_info_for
719
c22c7625 720Returns metadata for the given source's columns. This
721is *deprecated*, and will be removed before 1.0. You should
722be specifying the metadata yourself if you need it.
a3eaff0e 723
724=cut
725
046ad905 726sub columns_info_for { die "Virtual method!" }
727
728=head1 ENVIRONMENT VARIABLES
729
730=head2 DBIC_TRACE
731
732If C<DBIC_TRACE> is set then trace information
f92a9d79 733is produced (as when the L</debug> method is set).
046ad905 734
735If the value is of the form C<1=/path/name> then the trace output is
736written to the file C</path/name>.
737
738This environment variable is checked when the storage object is first
fd323bf1 739created (when you call connect on your schema). So, run-time changes
740to this environment variable will not take effect unless you also
046ad905 741re-connect on your schema.
742
b6cd6478 743=head2 DBIC_TRACE_PROFILE
744
2514a73f 745If C<DBIC_TRACE_PROFILE> is set, L<DBIx::Class::Storage::Debug::PrettyPrint>
b6cd6478 746will be used to format the output from C<DBIC_TRACE>. The value it
747is set to is the C<profile> that it will be used. If the value is a
748filename the file is read with L<Config::Any> and the results are
749used as the configuration for tracing. See L<SQL::Abstract::Tree/new>
750for what that structure should look like.
751
046ad905 752=head2 DBIX_CLASS_STORAGE_DBI_DEBUG
753
754Old name for DBIC_TRACE
755
ace385bd 756=head1 SEE ALSO
757
2f0790c4 758L<DBIx::Class::Storage::DBI> - reference storage implementation using
759SQL::Abstract and DBI.
ace385bd 760
a2bd3796 761=head1 FURTHER QUESTIONS?
046ad905 762
a2bd3796 763Check the list of L<additional DBIC resources|DBIx::Class/GETTING HELP/SUPPORT>.
046ad905 764
a2bd3796 765=head1 COPYRIGHT AND LICENSE
046ad905 766
a2bd3796 767This module is free software L<copyright|DBIx::Class/COPYRIGHT AND LICENSE>
768by the L<DBIx::Class (DBIC) authors|DBIx::Class/AUTHORS>. You can
769redistribute it and/or modify it under the same terms as the
770L<DBIx::Class library|DBIx::Class/COPYRIGHT AND LICENSE>.
046ad905 771
772=cut
773
a62cf8d4 7741;