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