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 Scalar::Util qw/blessed weaken/;
  17 use DBIx::Class::Storage::TxnScopeGuard;
  18 use Try::Tiny;
  19 use namespace::clean;
  20
  21 __PACKAGE__->mk_group_accessors(simple => qw/debug schema transaction_depth auto_savepoint savepoints/);
  22 __PACKAGE__->mk_group_accessors(component_class => 'cursor_class');
  23
  24 __PACKAGE__->cursor_class('DBIx::Class::Cursor');
  25
  26 sub cursor { shift->cursor_class(@_); }
  27
  28 =head1 NAME
  29
  30 DBIx::Class::Storage - Generic Storage Handler
  31
  32 =head1 DESCRIPTION
  33
  34 A base implementation of common Storage methods.  For specific
  35 information about L<DBI>-based storage, see L<DBIx::Class::Storage::DBI>.
  36
  37 =head1 METHODS
  38
  39 =head2 new
  40
  41 Arguments: $schema
  42
  43 Instantiates the Storage object.
  44
  45 =cut
  46
  47 sub new {
  48   my ($self, $schema) = @_;
  49
  50   $self = ref $self if ref $self;
  51
  52   my $new = bless( {
  53     transaction_depth => 0,
  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   my $coderef = shift;
 178
 179   ref $coderef eq 'CODE' or $self->throw_exception
 180     ('$coderef must be a CODE reference');
 181
 182   my $abort_txn = sub {
 183     my ($self, $exception) = @_;
 184
 185     my $rollback_exception = try { $self->txn_rollback; undef } catch { shift };
 186
 187     if ( $rollback_exception and (
 188       ! defined blessed $rollback_exception
 189           or
 190       ! $rollback_exception->isa('DBIx::Class::Storage::NESTED_ROLLBACK_EXCEPTION')
 191     ) ) {
 192       $self->throw_exception(
 193         "Transaction aborted: ${exception}. "
 194         . "Rollback failed: ${rollback_exception}"
 195       );
 196     }
 197     $self->throw_exception($exception);
 198   };
 199
 200   # take a ref instead of a copy, to preserve coderef @_ aliasing semantics
 201   my $args = \@_;
 202
 203   # do not turn on until a succesful txn_begin
 204   my $attempt_commit = 0;
 205
 206   my $txn_init_depth = $self->transaction_depth;
 207
 208   try {
 209     $self->txn_begin;
 210     $attempt_commit = 1;
 211     $coderef->(@$args)
 212   }
 213   catch {
 214     $attempt_commit = 0;
 215
 216     # init depth of > 0 implies nesting or non-autocommit (either way no retry)
 217     if($txn_init_depth or $self->connected ) {
 218       $abort_txn->($self, $_);
 219     }
 220     else {
 221       carp "Retrying txn_do($coderef) after catching disconnected exception: $_"
 222         if $ENV{DBIC_STORAGE_RETRY_DEBUG};
 223
 224       $self->_populate_dbh;
 225
 226       # if txn_depth is > 1 this means something was done to the
 227       # original $dbh, otherwise we would not get past the if() above
 228       $self->throw_exception(sprintf
 229         'Unexpected transaction depth of %d on freshly connected handle',
 230         $self->transaction_depth,
 231       ) if $self->transaction_depth;
 232
 233       $self->txn_begin;
 234       $attempt_commit = 1;
 235
 236       try {
 237         $coderef->(@$args)
 238       }
 239       catch {
 240         $attempt_commit = 0;
 241         $abort_txn->($self, $_)
 242       };
 243     };
 244   }
 245   finally {
 246     if ($attempt_commit) {
 247       my $delta_txn = (1 + $txn_init_depth) - $self->transaction_depth;
 248
 249       if ($delta_txn) {
 250         # a rollback in a top-level txn_do is valid-ish (seen in the wild and our own tests)
 251         carp "Unexpected reduction of transaction depth by $delta_txn after execution of $coderef, skipping txn_do's commit"
 252           unless $delta_txn == 1 and $self->transaction_depth == 0;
 253       }
 254       else {
 255         $self->txn_commit;
 256       }
 257     }
 258   };
 259 }
 260
 261 =head2 txn_begin
 262
 263 Starts a transaction.
 264
 265 See the preferred L</txn_do> method, which allows for
 266 an entire code block to be executed transactionally.
 267
 268 =cut
 269
 270 sub txn_begin {
 271   my $self = shift;
 272
 273   if($self->transaction_depth == 0) {
 274     $self->debugobj->txn_begin()
 275       if $self->debug;
 276     $self->_exec_txn_begin;
 277   }
 278   elsif ($self->auto_savepoint) {
 279     $self->svp_begin;
 280   }
 281   $self->{transaction_depth}++;
 282
 283 }
 284
 285 =head2 txn_commit
 286
 287 Issues a commit of the current transaction.
 288
 289 It does I<not> perform an actual storage commit unless there's a DBIx::Class
 290 transaction currently in effect (i.e. you called L</txn_begin>).
 291
 292 =cut
 293
 294 sub txn_commit {
 295   my $self = shift;
 296
 297   if ($self->transaction_depth == 1) {
 298     $self->debugobj->txn_commit() if $self->debug;
 299     $self->_exec_txn_commit;
 300     $self->{transaction_depth}--;
 301   }
 302   elsif($self->transaction_depth > 1) {
 303     $self->{transaction_depth}--;
 304     $self->svp_release if $self->auto_savepoint;
 305   }
 306   else {
 307     $self->throw_exception( 'Refusing to commit without a started transaction' );
 308   }
 309 }
 310
 311 =head2 txn_rollback
 312
 313 Issues a rollback of the current transaction. A nested rollback will
 314 throw a L<DBIx::Class::Storage::NESTED_ROLLBACK_EXCEPTION> exception,
 315 which allows the rollback to propagate to the outermost transaction.
 316
 317 =cut
 318
 319 sub txn_rollback {
 320   my $self = shift;
 321
 322   if ($self->transaction_depth == 1) {
 323     $self->debugobj->txn_rollback() if $self->debug;
 324     $self->_exec_txn_rollback;
 325     $self->{transaction_depth}--;
 326   }
 327   elsif ($self->transaction_depth > 1) {
 328     $self->{transaction_depth}--;
 329
 330     if ($self->auto_savepoint) {
 331       $self->svp_rollback;
 332       $self->svp_release;
 333     }
 334     else {
 335       DBIx::Class::Storage::NESTED_ROLLBACK_EXCEPTION->throw(
 336         "A txn_rollback in nested transaction is ineffective! (depth $self->{transaction_depth})"
 337       );
 338     }
 339   }
 340   else {
 341     $self->throw_exception( 'Refusing to roll back without a started transaction' );
 342   }
 343 }
 344
 345 =head2 svp_begin
 346
 347 Arguments: $savepoint_name?
 348
 349 Created a new savepoint using the name provided as argument. If no name
 350 is provided, a random name will be used.
 351
 352 =cut
 353
 354 sub svp_begin {
 355   my ($self, $name) = @_;
 356
 357   $self->throw_exception ("You can't use savepoints outside a transaction")
 358     unless $self->transaction_depth;
 359
 360   my $exec = $self->can('_exec_svp_begin')
 361     or $self->throw_exception ("Your Storage implementation doesn't support savepoints");
 362
 363   $name = $self->_svp_generate_name
 364     unless defined $name;
 365
 366   push @{ $self->{savepoints} }, $name;
 367
 368   $self->debugobj->svp_begin($name) if $self->debug;
 369
 370   $exec->($self, $name);
 371 }
 372
 373 sub _svp_generate_name {
 374   my ($self) = @_;
 375   return 'savepoint_'.scalar(@{ $self->{'savepoints'} });
 376 }
 377
 378
 379 =head2 svp_release
 380
 381 Arguments: $savepoint_name?
 382
 383 Release the savepoint provided as argument. If none is provided,
 384 release the savepoint created most recently. This will implicitly
 385 release all savepoints created after the one explicitly released as well.
 386
 387 =cut
 388
 389 sub svp_release {
 390   my ($self, $name) = @_;
 391
 392   $self->throw_exception ("You can't use savepoints outside a transaction")
 393     unless $self->transaction_depth;
 394
 395   my $exec = $self->can('_exec_svp_release')
 396     or $self->throw_exception ("Your Storage implementation doesn't support savepoints");
 397
 398   if (defined $name) {
 399     my @stack = @{ $self->savepoints };
 400     my $svp;
 401
 402     do { $svp = pop @stack } until $svp eq $name;
 403
 404     $self->throw_exception ("Savepoint '$name' does not exist")
 405       unless $svp;
 406
 407     $self->savepoints(\@stack); # put back what's left
 408   }
 409   else {
 410     $name = pop @{ $self->savepoints }
 411       or $self->throw_exception('No savepoints to release');;
 412   }
 413
 414   $self->debugobj->svp_release($name) if $self->debug;
 415
 416   $exec->($self, $name);
 417 }
 418
 419 =head2 svp_rollback
 420
 421 Arguments: $savepoint_name?
 422
 423 Rollback to the savepoint provided as argument. If none is provided,
 424 rollback to the savepoint created most recently. This will implicitly
 425 release all savepoints created after the savepoint we rollback to.
 426
 427 =cut
 428
 429 sub svp_rollback {
 430   my ($self, $name) = @_;
 431
 432   $self->throw_exception ("You can't use savepoints outside a transaction")
 433     unless $self->transaction_depth;
 434
 435   my $exec = $self->can('_exec_svp_rollback')
 436     or $self->throw_exception ("Your Storage implementation doesn't support savepoints");
 437
 438   if (defined $name) {
 439     my @stack = @{ $self->savepoints };
 440     my $svp;
 441
 442     # a rollback doesn't remove the named savepoint,
 443     # only everything after it
 444     while (@stack and $stack[-1] ne $name) {
 445       pop @stack
 446     };
 447
 448     $self->throw_exception ("Savepoint '$name' does not exist")
 449       unless @stack;
 450
 451     $self->savepoints(\@stack); # put back what's left
 452   }
 453   else {
 454     $name = $self->savepoints->[-1]
 455       or $self->throw_exception('No savepoints to rollback');;
 456   }
 457
 458   $self->debugobj->svp_rollback($name) if $self->debug;
 459
 460   $exec->($self, $name);
 461 }
 462
 463 =begin comment
 464
 465     =head2 txn_scope_guard
 466
 467     An alternative way of transaction handling based on
 468     L<DBIx::Class::Storage::TxnScopeGuard>:
 469
 470      my $txn_guard = $storage->txn_scope_guard;
 471
 472      $row->col1("val1");
 473      $row->update;
 474
 475      $txn_guard->commit;
 476
 477     If an exception occurs, or the guard object otherwise leaves the scope
 478     before C<< $txn_guard->commit >> is called, the transaction will be rolled
 479     back by an explicit L</txn_rollback> call. In essence this is akin to
 480     using a L</txn_begin>/L</txn_commit> pair, without having to worry
 481     about calling L</txn_rollback> at the right places. Note that since there
 482     is no defined code closure, there will be no retries and other magic upon
 483     database disconnection. If you need such functionality see L</txn_do>.
 484
 485 =end comment
 486
 487 =cut
 488
 489 sub txn_scope_guard {
 490   return DBIx::Class::Storage::TxnScopeGuard->new($_[0]);
 491 }
 492
 493 =head2 sql_maker
 494
 495 Returns a C<sql_maker> object - normally an object of class
 496 C<DBIx::Class::SQLMaker>.
 497
 498 =cut
 499
 500 sub sql_maker { die "Virtual method!" }
 501
 502 =head2 debug
 503
 504 Causes trace information to be emitted on the L</debugobj> object.
 505 (or C<STDERR> if L</debugobj> has not specifically been set).
 506
 507 This is the equivalent to setting L</DBIC_TRACE> in your
 508 shell environment.
 509
 510 =head2 debugfh
 511
 512 Set or retrieve the filehandle used for trace/debug output.  This should be
 513 an IO::Handle compatible object (only the C<print> method is used.  Initially
 514 set to be STDERR - although see information on the
 515 L<DBIC_TRACE> environment variable.
 516
 517 =cut
 518
 519 sub debugfh {
 520     my $self = shift;
 521
 522     if ($self->debugobj->can('debugfh')) {
 523         return $self->debugobj->debugfh(@_);
 524     }
 525 }
 526
 527 =head2 debugobj
 528
 529 Sets or retrieves the object used for metric collection. Defaults to an instance
 530 of L<DBIx::Class::Storage::Statistics> that is compatible with the original
 531 method of using a coderef as a callback.  See the aforementioned Statistics
 532 class for more information.
 533
 534 =cut
 535
 536 sub debugobj {
 537   my $self = shift;
 538
 539   if (@_) {
 540     return $self->{debugobj} = $_[0];
 541   }
 542
 543   $self->{debugobj} ||= do {
 544     if (my $profile = $ENV{DBIC_TRACE_PROFILE}) {
 545       require DBIx::Class::Storage::Debug::PrettyPrint;
 546       if ($profile =~ /^\.?\//) {
 547         require Config::Any;
 548
 549         my $cfg = try {
 550           Config::Any->load_files({ files => [$profile], use_ext => 1 });
 551         } catch {
 552           # sanitize the error message a bit
 553           $_ =~ s/at \s+ .+ Storage\.pm \s line \s \d+ $//x;
 554           $self->throw_exception("Failure processing \$ENV{DBIC_TRACE_PROFILE}: $_");
 555         };
 556
 557         DBIx::Class::Storage::Debug::PrettyPrint->new(values %{$cfg->[0]});
 558       }
 559       else {
 560         DBIx::Class::Storage::Debug::PrettyPrint->new({ profile => $profile });
 561       }
 562     }
 563     else {
 564       require DBIx::Class::Storage::Statistics;
 565       DBIx::Class::Storage::Statistics->new
 566     }
 567   };
 568 }
 569
 570 =head2 debugcb
 571
 572 Sets a callback to be executed each time a statement is run; takes a sub
 573 reference.  Callback is executed as $sub->($op, $info) where $op is
 574 SELECT/INSERT/UPDATE/DELETE and $info is what would normally be printed.
 575
 576 See L</debugobj> for a better way.
 577
 578 =cut
 579
 580 sub debugcb {
 581     my $self = shift;
 582
 583     if ($self->debugobj->can('callback')) {
 584         return $self->debugobj->callback(@_);
 585     }
 586 }
 587
 588 =head2 cursor_class
 589
 590 The cursor class for this Storage object.
 591
 592 =cut
 593
 594 =head2 deploy
 595
 596 Deploy the tables to storage (CREATE TABLE and friends in a SQL-based
 597 Storage class). This would normally be called through
 598 L<DBIx::Class::Schema/deploy>.
 599
 600 =cut
 601
 602 sub deploy { die "Virtual method!" }
 603
 604 =head2 connect_info
 605
 606 The arguments of C<connect_info> are always a single array reference,
 607 and are Storage-handler specific.
 608
 609 This is normally accessed via L<DBIx::Class::Schema/connection>, which
 610 encapsulates its argument list in an arrayref before calling
 611 C<connect_info> here.
 612
 613 =cut
 614
 615 sub connect_info { die "Virtual method!" }
 616
 617 =head2 select
 618
 619 Handle a select statement.
 620
 621 =cut
 622
 623 sub select { die "Virtual method!" }
 624
 625 =head2 insert
 626
 627 Handle an insert statement.
 628
 629 =cut
 630
 631 sub insert { die "Virtual method!" }
 632
 633 =head2 update
 634
 635 Handle an update statement.
 636
 637 =cut
 638
 639 sub update { die "Virtual method!" }
 640
 641 =head2 delete
 642
 643 Handle a delete statement.
 644
 645 =cut
 646
 647 sub delete { die "Virtual method!" }
 648
 649 =head2 select_single
 650
 651 Performs a select, fetch and return of data - handles a single row
 652 only.
 653
 654 =cut
 655
 656 sub select_single { die "Virtual method!" }
 657
 658 =head2 columns_info_for
 659
 660 Returns metadata for the given source's columns.  This
 661 is *deprecated*, and will be removed before 1.0.  You should
 662 be specifying the metadata yourself if you need it.
 663
 664 =cut
 665
 666 sub columns_info_for { die "Virtual method!" }
 667
 668 =head1 ENVIRONMENT VARIABLES
 669
 670 =head2 DBIC_TRACE
 671
 672 If C<DBIC_TRACE> is set then trace information
 673 is produced (as when the L</debug> method is set).
 674
 675 If the value is of the form C<1=/path/name> then the trace output is
 676 written to the file C</path/name>.
 677
 678 This environment variable is checked when the storage object is first
 679 created (when you call connect on your schema).  So, run-time changes
 680 to this environment variable will not take effect unless you also
 681 re-connect on your schema.
 682
 683 =head2 DBIC_TRACE_PROFILE
 684
 685 If C<DBIC_TRACE_PROFILE> is set, L<DBIx::Class::Storage::Debug::PrettyPrint>
 686 will be used to format the output from C<DBIC_TRACE>.  The value it
 687 is set to is the C<profile> that it will be used.  If the value is a
 688 filename the file is read with L<Config::Any> and the results are
 689 used as the configuration for tracing.  See L<SQL::Abstract::Tree/new>
 690 for what that structure should look like.
 691
 692
 693 =head2 DBIX_CLASS_STORAGE_DBI_DEBUG
 694
 695 Old name for DBIC_TRACE
 696
 697 =head1 SEE ALSO
 698
 699 L<DBIx::Class::Storage::DBI> - reference storage implementation using
 700 SQL::Abstract and DBI.
 701
 702 =head1 AUTHORS
 703
 704 Matt S. Trout <mst@shadowcatsystems.co.uk>
 705
 706 Andy Grundman <andy@hybridized.org>
 707
 708 =head1 LICENSE
 709
 710 You may distribute this code under the same terms as Perl itself.
 711
 712 =cut
 713
 714 1;