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