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