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   my $coderef = shift;
 179
 180   DBIx::Class::Storage::BlockRunner->new(
 181     storage => $self,
 182     run_code => $coderef,
 183     run_args => @_
 184       ? \@_   # take a ref instead of a copy, to preserve @_ aliasing
 185       : []    # semantics within the coderef, but only if needed
 186     ,         # (pseudoforking doesn't like this trick much)
 187     wrap_txn => 1,
 188     retry_handler => sub { ! ( $_[0]->retried_count or $_[0]->storage->connected ) },
 189   )->run;
 190 }
 191
 192 =head2 txn_begin
 193
 194 Starts a transaction.
 195
 196 See the preferred L</txn_do> method, which allows for
 197 an entire code block to be executed transactionally.
 198
 199 =cut
 200
 201 sub txn_begin {
 202   my $self = shift;
 203
 204   if($self->transaction_depth == 0) {
 205     $self->debugobj->txn_begin()
 206       if $self->debug;
 207     $self->_exec_txn_begin;
 208   }
 209   elsif ($self->auto_savepoint) {
 210     $self->svp_begin;
 211   }
 212   $self->{transaction_depth}++;
 213
 214 }
 215
 216 =head2 txn_commit
 217
 218 Issues a commit of the current transaction.
 219
 220 It does I<not> perform an actual storage commit unless there's a DBIx::Class
 221 transaction currently in effect (i.e. you called L</txn_begin>).
 222
 223 =cut
 224
 225 sub txn_commit {
 226   my $self = shift;
 227
 228   if ($self->transaction_depth == 1) {
 229     $self->debugobj->txn_commit() if $self->debug;
 230     $self->_exec_txn_commit;
 231     $self->{transaction_depth}--;
 232   }
 233   elsif($self->transaction_depth > 1) {
 234     $self->{transaction_depth}--;
 235     $self->svp_release if $self->auto_savepoint;
 236   }
 237   else {
 238     $self->throw_exception( 'Refusing to commit without a started transaction' );
 239   }
 240 }
 241
 242 =head2 txn_rollback
 243
 244 Issues a rollback of the current transaction. A nested rollback will
 245 throw a L<DBIx::Class::Storage::NESTED_ROLLBACK_EXCEPTION> exception,
 246 which allows the rollback to propagate to the outermost transaction.
 247
 248 =cut
 249
 250 sub txn_rollback {
 251   my $self = shift;
 252
 253   if ($self->transaction_depth == 1) {
 254     $self->debugobj->txn_rollback() if $self->debug;
 255     $self->_exec_txn_rollback;
 256     $self->{transaction_depth}--;
 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  $row->col1("val1");
 402  $row->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 Set or retrieve the filehandle used for trace/debug output.  This should be
 440 an IO::Handle compatible object (only the C<print> method is used.  Initially
 441 set to be STDERR - although see information on the
 442 L<DBIC_TRACE> environment variable.
 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       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         DBIx::Class::Storage::Debug::PrettyPrint->new(values %{$cfg->[0]});
 485       }
 486       else {
 487         DBIx::Class::Storage::Debug::PrettyPrint->new({ profile => $profile });
 488       }
 489     }
 490     else {
 491       require DBIx::Class::Storage::Statistics;
 492       DBIx::Class::Storage::Statistics->new
 493     }
 494   };
 495 }
 496
 497 =head2 debugcb
 498
 499 Sets a callback to be executed each time a statement is run; takes a sub
 500 reference.  Callback is executed as $sub->($op, $info) where $op is
 501 SELECT/INSERT/UPDATE/DELETE and $info is what would normally be printed.
 502
 503 See L</debugobj> for a better way.
 504
 505 =cut
 506
 507 sub debugcb {
 508     my $self = shift;
 509
 510     if ($self->debugobj->can('callback')) {
 511         return $self->debugobj->callback(@_);
 512     }
 513 }
 514
 515 =head2 cursor_class
 516
 517 The cursor class for this Storage object.
 518
 519 =cut
 520
 521 =head2 deploy
 522
 523 Deploy the tables to storage (CREATE TABLE and friends in a SQL-based
 524 Storage class). This would normally be called through
 525 L<DBIx::Class::Schema/deploy>.
 526
 527 =cut
 528
 529 sub deploy { die "Virtual method!" }
 530
 531 =head2 connect_info
 532
 533 The arguments of C<connect_info> are always a single array reference,
 534 and are Storage-handler specific.
 535
 536 This is normally accessed via L<DBIx::Class::Schema/connection>, which
 537 encapsulates its argument list in an arrayref before calling
 538 C<connect_info> here.
 539
 540 =cut
 541
 542 sub connect_info { die "Virtual method!" }
 543
 544 =head2 select
 545
 546 Handle a select statement.
 547
 548 =cut
 549
 550 sub select { die "Virtual method!" }
 551
 552 =head2 insert
 553
 554 Handle an insert statement.
 555
 556 =cut
 557
 558 sub insert { die "Virtual method!" }
 559
 560 =head2 update
 561
 562 Handle an update statement.
 563
 564 =cut
 565
 566 sub update { die "Virtual method!" }
 567
 568 =head2 delete
 569
 570 Handle a delete statement.
 571
 572 =cut
 573
 574 sub delete { die "Virtual method!" }
 575
 576 =head2 select_single
 577
 578 Performs a select, fetch and return of data - handles a single row
 579 only.
 580
 581 =cut
 582
 583 sub select_single { die "Virtual method!" }
 584
 585 =head2 columns_info_for
 586
 587 Returns metadata for the given source's columns.  This
 588 is *deprecated*, and will be removed before 1.0.  You should
 589 be specifying the metadata yourself if you need it.
 590
 591 =cut
 592
 593 sub columns_info_for { die "Virtual method!" }
 594
 595 =head1 ENVIRONMENT VARIABLES
 596
 597 =head2 DBIC_TRACE
 598
 599 If C<DBIC_TRACE> is set then trace information
 600 is produced (as when the L</debug> method is set).
 601
 602 If the value is of the form C<1=/path/name> then the trace output is
 603 written to the file C</path/name>.
 604
 605 This environment variable is checked when the storage object is first
 606 created (when you call connect on your schema).  So, run-time changes
 607 to this environment variable will not take effect unless you also
 608 re-connect on your schema.
 609
 610 =head2 DBIC_TRACE_PROFILE
 611
 612 If C<DBIC_TRACE_PROFILE> is set, L<DBIx::Class::Storage::Debug::PrettyPrint>
 613 will be used to format the output from C<DBIC_TRACE>.  The value it
 614 is set to is the C<profile> that it will be used.  If the value is a
 615 filename the file is read with L<Config::Any> and the results are
 616 used as the configuration for tracing.  See L<SQL::Abstract::Tree/new>
 617 for what that structure should look like.
 618
 619
 620 =head2 DBIX_CLASS_STORAGE_DBI_DEBUG
 621
 622 Old name for DBIC_TRACE
 623
 624 =head1 SEE ALSO
 625
 626 L<DBIx::Class::Storage::DBI> - reference storage implementation using
 627 SQL::Abstract and DBI.
 628
 629 =head1 AUTHOR AND CONTRIBUTORS
 630
 631 See L<AUTHOR|DBIx::Class/AUTHOR> and L<CONTRIBUTORS|DBIx::Class/CONTRIBUTORS> in DBIx::Class
 632
 633 =head1 LICENSE
 634
 635 You may distribute this code under the same terms as Perl itself.
 636
 637 =cut
 638
 639 1;