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     transaction_depth => 0,
  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   }
 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   }
 256   elsif ($self->transaction_depth > 1) {
 257     $self->{transaction_depth}--;
 258
 259     if ($self->auto_savepoint) {
 260       $self->svp_rollback;
 261       $self->svp_release;
 262     }
 263     else {
 264       DBIx::Class::Storage::NESTED_ROLLBACK_EXCEPTION->throw(
 265         "A txn_rollback in nested transaction is ineffective! (depth $self->{transaction_depth})"
 266       );
 267     }
 268   }
 269   else {
 270     $self->throw_exception( 'Refusing to roll back without a started transaction' );
 271   }
 272 }
 273
 274 =head2 svp_begin
 275
 276 Arguments: $savepoint_name?
 277
 278 Created a new savepoint using the name provided as argument. If no name
 279 is provided, a random name will be used.
 280
 281 =cut
 282
 283 sub svp_begin {
 284   my ($self, $name) = @_;
 285
 286   $self->throw_exception ("You can't use savepoints outside a transaction")
 287     unless $self->transaction_depth;
 288
 289   my $exec = $self->can('_exec_svp_begin')
 290     or $self->throw_exception ("Your Storage implementation doesn't support savepoints");
 291
 292   $name = $self->_svp_generate_name
 293     unless defined $name;
 294
 295   push @{ $self->{savepoints} }, $name;
 296
 297   $self->debugobj->svp_begin($name) if $self->debug;
 298
 299   $exec->($self, $name);
 300 }
 301
 302 sub _svp_generate_name {
 303   my ($self) = @_;
 304   return 'savepoint_'.scalar(@{ $self->{'savepoints'} });
 305 }
 306
 307
 308 =head2 svp_release
 309
 310 Arguments: $savepoint_name?
 311
 312 Release the savepoint provided as argument. If none is provided,
 313 release the savepoint created most recently. This will implicitly
 314 release all savepoints created after the one explicitly released as well.
 315
 316 =cut
 317
 318 sub svp_release {
 319   my ($self, $name) = @_;
 320
 321   $self->throw_exception ("You can't use savepoints outside a transaction")
 322     unless $self->transaction_depth;
 323
 324   my $exec = $self->can('_exec_svp_release')
 325     or $self->throw_exception ("Your Storage implementation doesn't support savepoints");
 326
 327   if (defined $name) {
 328     my @stack = @{ $self->savepoints };
 329     my $svp;
 330
 331     do { $svp = pop @stack } until $svp eq $name;
 332
 333     $self->throw_exception ("Savepoint '$name' does not exist")
 334       unless $svp;
 335
 336     $self->savepoints(\@stack); # put back what's left
 337   }
 338   else {
 339     $name = pop @{ $self->savepoints }
 340       or $self->throw_exception('No savepoints to release');;
 341   }
 342
 343   $self->debugobj->svp_release($name) if $self->debug;
 344
 345   $exec->($self, $name);
 346 }
 347
 348 =head2 svp_rollback
 349
 350 Arguments: $savepoint_name?
 351
 352 Rollback to the savepoint provided as argument. If none is provided,
 353 rollback to the savepoint created most recently. This will implicitly
 354 release all savepoints created after the savepoint we rollback to.
 355
 356 =cut
 357
 358 sub svp_rollback {
 359   my ($self, $name) = @_;
 360
 361   $self->throw_exception ("You can't use savepoints outside a transaction")
 362     unless $self->transaction_depth;
 363
 364   my $exec = $self->can('_exec_svp_rollback')
 365     or $self->throw_exception ("Your Storage implementation doesn't support savepoints");
 366
 367   if (defined $name) {
 368     my @stack = @{ $self->savepoints };
 369     my $svp;
 370
 371     # a rollback doesn't remove the named savepoint,
 372     # only everything after it
 373     while (@stack and $stack[-1] ne $name) {
 374       pop @stack
 375     };
 376
 377     $self->throw_exception ("Savepoint '$name' does not exist")
 378       unless @stack;
 379
 380     $self->savepoints(\@stack); # put back what's left
 381   }
 382   else {
 383     $name = $self->savepoints->[-1]
 384       or $self->throw_exception('No savepoints to rollback');;
 385   }
 386
 387   $self->debugobj->svp_rollback($name) if $self->debug;
 388
 389   $exec->($self, $name);
 390 }
 391
 392 =head2 txn_scope_guard
 393
 394 An alternative way of transaction handling based on
 395 L<DBIx::Class::Storage::TxnScopeGuard>:
 396
 397  my $txn_guard = $storage->txn_scope_guard;
 398
 399  $result->col1("val1");
 400  $result->update;
 401
 402  $txn_guard->commit;
 403
 404 If an exception occurs, or the guard object otherwise leaves the scope
 405 before C<< $txn_guard->commit >> is called, the transaction will be rolled
 406 back by an explicit L</txn_rollback> call. In essence this is akin to
 407 using a L</txn_begin>/L</txn_commit> pair, without having to worry
 408 about calling L</txn_rollback> at the right places. Note that since there
 409 is no defined code closure, there will be no retries and other magic upon
 410 database disconnection. If you need such functionality see L</txn_do>.
 411
 412 =cut
 413
 414 sub txn_scope_guard {
 415   return DBIx::Class::Storage::TxnScopeGuard->new($_[0]);
 416 }
 417
 418 =head2 sql_maker
 419
 420 Returns a C<sql_maker> object - normally an object of class
 421 C<DBIx::Class::SQLMaker>.
 422
 423 =cut
 424
 425 sub sql_maker { die "Virtual method!" }
 426
 427 =head2 debug
 428
 429 Causes trace information to be emitted on the L</debugobj> object.
 430 (or C<STDERR> if L</debugobj> has not specifically been set).
 431
 432 This is the equivalent to setting L</DBIC_TRACE> in your
 433 shell environment.
 434
 435 =head2 debugfh
 436
 437 Set or retrieve the filehandle used for trace/debug output.  This should be
 438 an IO::Handle compatible object (only the C<print> method is used).  Initially
 439 set to be STDERR - although see information on the
 440 L<DBIC_TRACE> environment variable.
 441
 442 =cut
 443
 444 sub debugfh {
 445     my $self = shift;
 446
 447     if ($self->debugobj->can('debugfh')) {
 448         return $self->debugobj->debugfh(@_);
 449     }
 450 }
 451
 452 =head2 debugobj
 453
 454 Sets or retrieves the object used for metric collection. Defaults to an instance
 455 of L<DBIx::Class::Storage::Statistics> that is compatible with the original
 456 method of using a coderef as a callback.  See the aforementioned Statistics
 457 class for more information.
 458
 459 =cut
 460
 461 sub debugobj {
 462   my $self = shift;
 463
 464   if (@_) {
 465     return $self->{debugobj} = $_[0];
 466   }
 467
 468   $self->{debugobj} ||= do {
 469     if (my $profile = $ENV{DBIC_TRACE_PROFILE}) {
 470       require DBIx::Class::Storage::Debug::PrettyPrint;
 471       my @pp_args;
 472
 473       if ($profile =~ /^\.?\//) {
 474         require Config::Any;
 475
 476         my $cfg = try {
 477           Config::Any->load_files({ files => [$profile], use_ext => 1 });
 478         } catch {
 479           # sanitize the error message a bit
 480           $_ =~ s/at \s+ .+ Storage\.pm \s line \s \d+ $//x;
 481           $self->throw_exception("Failure processing \$ENV{DBIC_TRACE_PROFILE}: $_");
 482         };
 483
 484         @pp_args = values %{$cfg->[0]};
 485       }
 486       else {
 487         @pp_args = { profile => $profile };
 488       }
 489
 490       # FIXME - FRAGILE
 491       # Hash::Merge is a sorry piece of shit and tramples all over $@
 492       # *without* throwing an exception
 493       # This is a rather serious problem in the debug codepath
 494       # Insulate the condition here with a try{} until a review of
 495       # DBIx::Class::Storage::Debug::PrettyPrint takes place
 496       # we do rethrow the error unconditionally, the only reason
 497       # to try{} is to preserve the precise state of $@ (down
 498       # to the scalar (if there is one) address level)
 499       #
 500       # Yes I am aware this is fragile and TxnScopeGuard needs
 501       # a better fix. This is another yak to shave... :(
 502       try {
 503         DBIx::Class::Storage::Debug::PrettyPrint->new(@pp_args);
 504       } catch {
 505         $self->throw_exception($_);
 506       }
 507     }
 508     else {
 509       require DBIx::Class::Storage::Statistics;
 510       DBIx::Class::Storage::Statistics->new
 511     }
 512   };
 513 }
 514
 515 =head2 debugcb
 516
 517 Sets a callback to be executed each time a statement is run; takes a sub
 518 reference.  Callback is executed as $sub->($op, $info) where $op is
 519 SELECT/INSERT/UPDATE/DELETE and $info is what would normally be printed.
 520
 521 See L</debugobj> for a better way.
 522
 523 =cut
 524
 525 sub debugcb {
 526     my $self = shift;
 527
 528     if ($self->debugobj->can('callback')) {
 529         return $self->debugobj->callback(@_);
 530     }
 531 }
 532
 533 =head2 cursor_class
 534
 535 The cursor class for this Storage object.
 536
 537 =cut
 538
 539 =head2 deploy
 540
 541 Deploy the tables to storage (CREATE TABLE and friends in a SQL-based
 542 Storage class). This would normally be called through
 543 L<DBIx::Class::Schema/deploy>.
 544
 545 =cut
 546
 547 sub deploy { die "Virtual method!" }
 548
 549 =head2 connect_info
 550
 551 The arguments of C<connect_info> are always a single array reference,
 552 and are Storage-handler specific.
 553
 554 This is normally accessed via L<DBIx::Class::Schema/connection>, which
 555 encapsulates its argument list in an arrayref before calling
 556 C<connect_info> here.
 557
 558 =cut
 559
 560 sub connect_info { die "Virtual method!" }
 561
 562 =head2 select
 563
 564 Handle a select statement.
 565
 566 =cut
 567
 568 sub select { die "Virtual method!" }
 569
 570 =head2 insert
 571
 572 Handle an insert statement.
 573
 574 =cut
 575
 576 sub insert { die "Virtual method!" }
 577
 578 =head2 update
 579
 580 Handle an update statement.
 581
 582 =cut
 583
 584 sub update { die "Virtual method!" }
 585
 586 =head2 delete
 587
 588 Handle a delete statement.
 589
 590 =cut
 591
 592 sub delete { die "Virtual method!" }
 593
 594 =head2 select_single
 595
 596 Performs a select, fetch and return of data - handles a single row
 597 only.
 598
 599 =cut
 600
 601 sub select_single { die "Virtual method!" }
 602
 603 =head2 columns_info_for
 604
 605 Returns metadata for the given source's columns.  This
 606 is *deprecated*, and will be removed before 1.0.  You should
 607 be specifying the metadata yourself if you need it.
 608
 609 =cut
 610
 611 sub columns_info_for { die "Virtual method!" }
 612
 613 =head1 ENVIRONMENT VARIABLES
 614
 615 =head2 DBIC_TRACE
 616
 617 If C<DBIC_TRACE> is set then trace information
 618 is produced (as when the L</debug> method is set).
 619
 620 If the value is of the form C<1=/path/name> then the trace output is
 621 written to the file C</path/name>.
 622
 623 This environment variable is checked when the storage object is first
 624 created (when you call connect on your schema).  So, run-time changes
 625 to this environment variable will not take effect unless you also
 626 re-connect on your schema.
 627
 628 =head2 DBIC_TRACE_PROFILE
 629
 630 If C<DBIC_TRACE_PROFILE> is set, L<DBIx::Class::Storage::Debug::PrettyPrint>
 631 will be used to format the output from C<DBIC_TRACE>.  The value it
 632 is set to is the C<profile> that it will be used.  If the value is a
 633 filename the file is read with L<Config::Any> and the results are
 634 used as the configuration for tracing.  See L<SQL::Abstract::Tree/new>
 635 for what that structure should look like.
 636
 637
 638 =head2 DBIX_CLASS_STORAGE_DBI_DEBUG
 639
 640 Old name for DBIC_TRACE
 641
 642 =head1 SEE ALSO
 643
 644 L<DBIx::Class::Storage::DBI> - reference storage implementation using
 645 SQL::Abstract and DBI.
 646
 647 =head1 AUTHOR AND CONTRIBUTORS
 648
 649 See L<AUTHOR|DBIx::Class/AUTHOR> and L<CONTRIBUTORS|DBIx::Class/CONTRIBUTORS> in DBIx::Class
 650
 651 =head1 LICENSE
 652
 653 You may distribute this code under the same terms as Perl itself.
 654
 655 =cut
 656
 657 1;