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