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