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 'dbic_internal_try';
  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 { shift->cursor_class(@_); }
  29
  30 =head1 NAME
  31
  32 DBIx::Class::Storage - Generic Storage Handler
  33
  34 =head1 DESCRIPTION
  35
  36 A base implementation of common Storage methods.  For specific
  37 information about L<DBI>-based storage, see L<DBIx::Class::Storage::DBI>.
  38
  39 =head1 METHODS
  40
  41 =head2 new
  42
  43 Arguments: $schema
  44
  45 Instantiates the Storage object.
  46
  47 =cut
  48
  49 sub new {
  50   my ($self, $schema) = @_;
  51
  52   $self = ref $self if ref $self;
  53
  54   my $new = bless( {
  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->{transaction_depth}--;
 255
 256     # in case things get really hairy - just disconnect
 257     dbic_internal_try { $self->_exec_txn_rollback; 1 } or do {
 258       my $rollback_error = $@;
 259
 260       # whatever happens, too low down the stack to care
 261       # FIXME - revisit if stackable exceptions become a thing
 262       dbic_internal_try { $self->disconnect };
 263
 264       die $rollback_error;
 265     };
 266
 267     $self->savepoints([]);
 268   }
 269   elsif ($self->transaction_depth > 1) {
 270     $self->{transaction_depth}--;
 271
 272     if ($self->auto_savepoint) {
 273       $self->svp_rollback;
 274       $self->svp_release;
 275     }
 276     else {
 277       DBIx::Class::Storage::NESTED_ROLLBACK_EXCEPTION->throw(
 278         "A txn_rollback in nested transaction is ineffective! (depth $self->{transaction_depth})"
 279       );
 280     }
 281   }
 282   else {
 283     $self->throw_exception( 'Refusing to roll back without a started transaction' );
 284   }
 285 }
 286
 287 # to be called by several internal stacked transaction handler codepaths
 288 # not for external consumption
 289 # *DOES NOT* throw exceptions, instead:
 290 #  - returns false on success
 291 #  - returns the exception on failed rollback
 292 sub __delicate_rollback {
 293   my $self = shift;
 294
 295   if (
 296     ( $self->transaction_depth || 0 ) > 1
 297       and
 298     # FIXME - the autosvp check here shouldn't be happening, it should be a role-ish thing
 299     # The entire concept needs to be rethought with the storage layer... or something
 300     ! $self->auto_savepoint
 301       and
 302     # the handle seems healthy, and there is nothing for us to do with it
 303     # just go ahead and bow out, without triggering the txn_rollback() "nested exception"
 304     # the unwind will eventually fail somewhere higher up if at all
 305     # FIXME: a ::Storage::DBI-specific method, not a generic ::Storage one
 306     $self->_seems_connected
 307   ) {
 308     # all above checks out - there is nothing to do on the $dbh itself
 309     # just a plain soft-decrease of depth
 310     $self->{transaction_depth}--;
 311     return;
 312   }
 313
 314   my @args = @_;
 315   my $rbe;
 316
 317   dbic_internal_try {
 318     $self->txn_rollback; 1
 319   }
 320   catch {
 321
 322     $rbe = $_;
 323
 324     # we were passed an existing exception to augment (think DESTROY stacks etc)
 325     if (@args) {
 326       my ($exception) = @args;
 327
 328       # append our text - THIS IS A TEMPORARY FIXUP!
 329       #
 330       # If the passed in exception is a reference, or an object we don't know
 331       # how to augment - flattening it is just damn rude
 332       if (
 333         # FIXME - a better way, not liable to destroy an existing exception needs
 334         # to be created. For the time being perpetuating the sin below in order
 335         # to break the deadlock of which yak is being shaved first
 336         0
 337           and
 338         length ref $$exception
 339           and
 340         (
 341           ! defined blessed $$exception
 342             or
 343           ! $$exception->isa( 'DBIx::Class::Exception' )
 344         )
 345       ) {
 346
 347         ##################
 348         ### FIXME - TODO
 349         ##################
 350
 351       }
 352       else {
 353
 354         # SUCH HIDEOUS, MUCH AUGH! (and double WOW on the s/// at the end below)
 355         $rbe =~ s/ at .+? line \d+$//;
 356
 357         (
 358           (
 359             defined blessed $$exception
 360               and
 361             $$exception->isa( 'DBIx::Class::Exception' )
 362           )
 363             ? (
 364               $$exception->{msg} =
 365                 "Transaction aborted: $$exception->{msg}. Rollback failed: $rbe"
 366             )
 367             : (
 368               $$exception =
 369                 "Transaction aborted: $$exception. Rollback failed: $rbe"
 370             )
 371         ) =~ s/Transaction aborted: (?=Transaction aborted:)//;
 372       }
 373     }
 374   };
 375
 376   return $rbe;
 377 }
 378
 379 =head2 svp_begin
 380
 381 Arguments: $savepoint_name?
 382
 383 Created a new savepoint using the name provided as argument. If no name
 384 is provided, a random name will be used.
 385
 386 =cut
 387
 388 sub svp_begin {
 389   my ($self, $name) = @_;
 390
 391   $self->throw_exception ("You can't use savepoints outside a transaction")
 392     unless $self->transaction_depth;
 393
 394   my $exec = $self->can('_exec_svp_begin')
 395     or $self->throw_exception ("Your Storage implementation doesn't support savepoints");
 396
 397   $name = $self->_svp_generate_name
 398     unless defined $name;
 399
 400   push @{ $self->{savepoints} }, $name;
 401
 402   $self->debugobj->svp_begin($name) if $self->debug;
 403
 404   $exec->($self, $name);
 405 }
 406
 407 sub _svp_generate_name {
 408   my ($self) = @_;
 409   return 'savepoint_'.scalar(@{ $self->{'savepoints'} });
 410 }
 411
 412
 413 =head2 svp_release
 414
 415 Arguments: $savepoint_name?
 416
 417 Release the savepoint provided as argument. If none is provided,
 418 release the savepoint created most recently. This will implicitly
 419 release all savepoints created after the one explicitly released as well.
 420
 421 =cut
 422
 423 sub svp_release {
 424   my ($self, $name) = @_;
 425
 426   $self->throw_exception ("You can't use savepoints outside a transaction")
 427     unless $self->transaction_depth;
 428
 429   my $exec = $self->can('_exec_svp_release')
 430     or $self->throw_exception ("Your Storage implementation doesn't support savepoints");
 431
 432   if (defined $name) {
 433     my @stack = @{ $self->savepoints };
 434     my $svp;
 435
 436     do { $svp = pop @stack } until $svp eq $name;
 437
 438     $self->throw_exception ("Savepoint '$name' does not exist")
 439       unless $svp;
 440
 441     $self->savepoints(\@stack); # put back what's left
 442   }
 443   else {
 444     $name = pop @{ $self->savepoints }
 445       or $self->throw_exception('No savepoints to release');;
 446   }
 447
 448   $self->debugobj->svp_release($name) if $self->debug;
 449
 450   $exec->($self, $name);
 451 }
 452
 453 =head2 svp_rollback
 454
 455 Arguments: $savepoint_name?
 456
 457 Rollback to the savepoint provided as argument. If none is provided,
 458 rollback to the savepoint created most recently. This will implicitly
 459 release all savepoints created after the savepoint we rollback to.
 460
 461 =cut
 462
 463 sub svp_rollback {
 464   my ($self, $name) = @_;
 465
 466   $self->throw_exception ("You can't use savepoints outside a transaction")
 467     unless $self->transaction_depth;
 468
 469   my $exec = $self->can('_exec_svp_rollback')
 470     or $self->throw_exception ("Your Storage implementation doesn't support savepoints");
 471
 472   if (defined $name) {
 473     my @stack = @{ $self->savepoints };
 474     my $svp;
 475
 476     # a rollback doesn't remove the named savepoint,
 477     # only everything after it
 478     while (@stack and $stack[-1] ne $name) {
 479       pop @stack
 480     };
 481
 482     $self->throw_exception ("Savepoint '$name' does not exist")
 483       unless @stack;
 484
 485     $self->savepoints(\@stack); # put back what's left
 486   }
 487   else {
 488     $name = $self->savepoints->[-1]
 489       or $self->throw_exception('No savepoints to rollback');;
 490   }
 491
 492   $self->debugobj->svp_rollback($name) if $self->debug;
 493
 494   $exec->($self, $name);
 495 }
 496
 497 =head2 txn_scope_guard
 498
 499 An alternative way of transaction handling based on
 500 L<DBIx::Class::Storage::TxnScopeGuard>:
 501
 502  my $txn_guard = $storage->txn_scope_guard;
 503
 504  $result->col1("val1");
 505  $result->update;
 506
 507  $txn_guard->commit;
 508
 509 If an exception occurs, or the guard object otherwise leaves the scope
 510 before C<< $txn_guard->commit >> is called, the transaction will be rolled
 511 back by an explicit L</txn_rollback> call. In essence this is akin to
 512 using a L</txn_begin>/L</txn_commit> pair, without having to worry
 513 about calling L</txn_rollback> at the right places. Note that since there
 514 is no defined code closure, there will be no retries and other magic upon
 515 database disconnection. If you need such functionality see L</txn_do>.
 516
 517 =cut
 518
 519 sub txn_scope_guard {
 520   return DBIx::Class::Storage::TxnScopeGuard->new($_[0]);
 521 }
 522
 523 =head2 sql_maker
 524
 525 Returns a C<sql_maker> object - normally an object of class
 526 C<DBIx::Class::SQLMaker>.
 527
 528 =cut
 529
 530 sub sql_maker { die "Virtual method!" }
 531
 532 =head2 debug
 533
 534 Causes trace information to be emitted on the L</debugobj> object.
 535 (or C<STDERR> if L</debugobj> has not specifically been set).
 536
 537 This is the equivalent to setting L</DBIC_TRACE> in your
 538 shell environment.
 539
 540 =head2 debugfh
 541
 542 An opportunistic proxy to L<< ->debugobj->debugfh(@_)
 543 |DBIx::Class::Storage::Statistics/debugfh >>
 544 If the currently set L</debugobj> does not have a L</debugfh> method, caling
 545 this is a no-op.
 546
 547 =cut
 548
 549 sub debugfh {
 550     my $self = shift;
 551
 552     if ($self->debugobj->can('debugfh')) {
 553         return $self->debugobj->debugfh(@_);
 554     }
 555 }
 556
 557 =head2 debugobj
 558
 559 Sets or retrieves the object used for metric collection. Defaults to an instance
 560 of L<DBIx::Class::Storage::Statistics> that is compatible with the original
 561 method of using a coderef as a callback.  See the aforementioned Statistics
 562 class for more information.
 563
 564 =cut
 565
 566 sub debugobj {
 567   my $self = shift;
 568
 569   if (@_) {
 570     return $self->{debugobj} = $_[0];
 571   }
 572
 573   $self->{debugobj} ||= do {
 574     if (my $profile = $ENV{DBIC_TRACE_PROFILE}) {
 575       require DBIx::Class::Storage::Debug::PrettyPrint;
 576       my @pp_args;
 577
 578       if ($profile =~ /^\.?\//) {
 579
 580         if ( my $missing = DBIx::Class::Optional::Dependencies->req_missing_for ('config_file_reader') ) {
 581           $self->throw_exception("Unable to parse TRACE_PROFILE config file '$profile' without $missing");
 582         }
 583
 584         my $cfg = dbic_internal_try {
 585           Config::Any->load_files({ files => [$profile], use_ext => 1 });
 586         } catch {
 587           # sanitize the error message a bit
 588           $_ =~ s/at \s+ .+ Storage\.pm \s line \s \d+ $//x;
 589           $self->throw_exception("Failure processing \$ENV{DBIC_TRACE_PROFILE}: $_");
 590         };
 591
 592         @pp_args = values %{$cfg->[0]};
 593       }
 594       else {
 595         @pp_args = { profile => $profile };
 596       }
 597
 598       # FIXME - FRAGILE
 599       # Hash::Merge is a sorry piece of shit and tramples all over $@
 600       # *without* throwing an exception
 601       # This is a rather serious problem in the debug codepath
 602       # Insulate the condition here with a try{} until a review of
 603       # DBIx::Class::Storage::Debug::PrettyPrint takes place
 604       # we do rethrow the error unconditionally, the only reason
 605       # to try{} is to preserve the precise state of $@ (down
 606       # to the scalar (if there is one) address level)
 607       #
 608       # Yes I am aware this is fragile and TxnScopeGuard needs
 609       # a better fix. This is another yak to shave... :(
 610       dbic_internal_try {
 611         DBIx::Class::Storage::Debug::PrettyPrint->new(@pp_args);
 612       } catch {
 613         $self->throw_exception($_);
 614       }
 615     }
 616     else {
 617       require DBIx::Class::Storage::Statistics;
 618       DBIx::Class::Storage::Statistics->new
 619     }
 620   };
 621 }
 622
 623 =head2 debugcb
 624
 625 Sets a callback to be executed each time a statement is run; takes a sub
 626 reference.  Callback is executed as $sub->($op, $info) where $op is
 627 SELECT/INSERT/UPDATE/DELETE and $info is what would normally be printed.
 628
 629 See L</debugobj> for a better way.
 630
 631 =cut
 632
 633 sub debugcb {
 634     my $self = shift;
 635
 636     if ($self->debugobj->can('callback')) {
 637         return $self->debugobj->callback(@_);
 638     }
 639 }
 640
 641 =head2 cursor_class
 642
 643 The cursor class for this Storage object.
 644
 645 =cut
 646
 647 =head2 deploy
 648
 649 Deploy the tables to storage (CREATE TABLE and friends in a SQL-based
 650 Storage class). This would normally be called through
 651 L<DBIx::Class::Schema/deploy>.
 652
 653 =cut
 654
 655 sub deploy { die "Virtual method!" }
 656
 657 =head2 connect_info
 658
 659 The arguments of C<connect_info> are always a single array reference,
 660 and are Storage-handler specific.
 661
 662 This is normally accessed via L<DBIx::Class::Schema/connection>, which
 663 encapsulates its argument list in an arrayref before calling
 664 C<connect_info> here.
 665
 666 =cut
 667
 668 sub connect_info { die "Virtual method!" }
 669
 670 =head2 select
 671
 672 Handle a select statement.
 673
 674 =cut
 675
 676 sub select { die "Virtual method!" }
 677
 678 =head2 insert
 679
 680 Handle an insert statement.
 681
 682 =cut
 683
 684 sub insert { die "Virtual method!" }
 685
 686 =head2 update
 687
 688 Handle an update statement.
 689
 690 =cut
 691
 692 sub update { die "Virtual method!" }
 693
 694 =head2 delete
 695
 696 Handle a delete statement.
 697
 698 =cut
 699
 700 sub delete { die "Virtual method!" }
 701
 702 =head2 select_single
 703
 704 Performs a select, fetch and return of data - handles a single row
 705 only.
 706
 707 =cut
 708
 709 sub select_single { die "Virtual method!" }
 710
 711 =head2 columns_info_for
 712
 713 Returns metadata for the given source's columns.  This
 714 is *deprecated*, and will be removed before 1.0.  You should
 715 be specifying the metadata yourself if you need it.
 716
 717 =cut
 718
 719 sub columns_info_for { die "Virtual method!" }
 720
 721 =head1 ENVIRONMENT VARIABLES
 722
 723 =head2 DBIC_TRACE
 724
 725 If C<DBIC_TRACE> is set then trace information
 726 is produced (as when the L</debug> method is set).
 727
 728 If the value is of the form C<1=/path/name> then the trace output is
 729 written to the file C</path/name>.
 730
 731 This environment variable is checked when the storage object is first
 732 created (when you call connect on your schema).  So, run-time changes
 733 to this environment variable will not take effect unless you also
 734 re-connect on your schema.
 735
 736 =head2 DBIC_TRACE_PROFILE
 737
 738 If C<DBIC_TRACE_PROFILE> is set, L<DBIx::Class::Storage::Debug::PrettyPrint>
 739 will be used to format the output from C<DBIC_TRACE>.  The value it
 740 is set to is the C<profile> that it will be used.  If the value is a
 741 filename the file is read with L<Config::Any> and the results are
 742 used as the configuration for tracing.  See L<SQL::Abstract::Tree/new>
 743 for what that structure should look like.
 744
 745 =head2 DBIX_CLASS_STORAGE_DBI_DEBUG
 746
 747 Old name for DBIC_TRACE
 748
 749 =head1 SEE ALSO
 750
 751 L<DBIx::Class::Storage::DBI> - reference storage implementation using
 752 SQL::Abstract and DBI.
 753
 754 =head1 FURTHER QUESTIONS?
 755
 756 Check the list of L<additional DBIC resources|DBIx::Class/GETTING HELP/SUPPORT>.
 757
 758 =head1 COPYRIGHT AND LICENSE
 759
 760 This module is free software L<copyright|DBIx::Class/COPYRIGHT AND LICENSE>
 761 by the L<DBIx::Class (DBIC) authors|DBIx::Class/AUTHORS>. You can
 762 redistribute it and/or modify it under the same terms as the
 763 L<DBIx::Class library|DBIx::Class/COPYRIGHT AND LICENSE>.
 764
 765 =cut
 766
 767 1;