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;