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
   8 use Scalar::Util qw/weaken/;
   9 use Carp::Clan qw/^DBIx::Class/;
  10 use IO::File;
  11
  12 __PACKAGE__->mk_group_accessors('simple' => qw/debug debugobj schema/);
  13 __PACKAGE__->mk_group_accessors('inherited' => 'cursor_class');
  14
  15 __PACKAGE__->cursor_class('DBIx::Class::Cursor');
  16
  17 sub cursor { shift->cursor_class(@_); }
  18
  19 package # Hide from PAUSE
  20     DBIx::Class::Storage::NESTED_ROLLBACK_EXCEPTION;
  21
  22 use overload '"' => sub {
  23   'DBIx::Class::Storage::NESTED_ROLLBACK_EXCEPTION'
  24 };
  25
  26 sub new {
  27   my $class = shift;
  28   my $self = {};
  29   return bless $self, $class;
  30 }
  31
  32 package DBIx::Class::Storage;
  33
  34 =head1 NAME
  35
  36 DBIx::Class::Storage - Generic Storage Handler
  37
  38 =head1 DESCRIPTION
  39
  40 A base implementation of common Storage methods.  For specific
  41 information about L<DBI>-based storage, see L<DBIx::Class::Storage::DBI>.
  42
  43 =head1 METHODS
  44
  45 =head2 new
  46
  47 Arguments: $schema
  48
  49 Instantiates the Storage object.
  50
  51 =cut
  52
  53 sub new {
  54   my ($self, $schema) = @_;
  55
  56   $self = ref $self if ref $self;
  57
  58   my $new = {};
  59   bless $new, $self;
  60
  61   $new->set_schema($schema);
  62   $new->debugobj(new DBIx::Class::Storage::Statistics());
  63
  64   #my $fh;
  65
  66   my $debug_env = $ENV{DBIX_CLASS_STORAGE_DBI_DEBUG}
  67                   || $ENV{DBIC_TRACE};
  68
  69   $new->debug(1) if $debug_env;
  70
  71   $new;
  72 }
  73
  74 =head2 set_schema
  75
  76 Used to reset the schema class or object which owns this
  77 storage object, such as during L<DBIx::Class::Schema/clone>.
  78
  79 =cut
  80
  81 sub set_schema {
  82   my ($self, $schema) = @_;
  83   $self->schema($schema);
  84   weaken($self->{schema}) if ref $self->{schema};
  85 }
  86
  87 =head2 connected
  88
  89 Returns true if we have an open storage connection, false
  90 if it is not (yet) open.
  91
  92 =cut
  93
  94 sub connected { die "Virtual method!" }
  95
  96 =head2 disconnect
  97
  98 Closes any open storage connection unconditionally.
  99
 100 =cut
 101
 102 sub disconnect { die "Virtual method!" }
 103
 104 =head2 ensure_connected
 105
 106 Initiate a connection to the storage if one isn't already open.
 107
 108 =cut
 109
 110 sub ensure_connected { die "Virtual method!" }
 111
 112 =head2 throw_exception
 113
 114 Throws an exception - croaks.
 115
 116 =cut
 117
 118 sub throw_exception {
 119   my $self = shift;
 120
 121   $self->schema->throw_exception(@_) if $self->schema;
 122   croak @_;
 123 }
 124
 125 =head2 txn_do
 126
 127 =over 4
 128
 129 =item Arguments: C<$coderef>, @coderef_args?
 130
 131 =item Return Value: The return value of $coderef
 132
 133 =back
 134
 135 Executes C<$coderef> with (optional) arguments C<@coderef_args> atomically,
 136 returning its result (if any). If an exception is caught, a rollback is issued
 137 and the exception is rethrown. If the rollback fails, (i.e. throws an
 138 exception) an exception is thrown that includes a "Rollback failed" message.
 139
 140 For example,
 141
 142   my $author_rs = $schema->resultset('Author')->find(1);
 143   my @titles = qw/Night Day It/;
 144
 145   my $coderef = sub {
 146     # If any one of these fails, the entire transaction fails
 147     $author_rs->create_related('books', {
 148       title => $_
 149     }) foreach (@titles);
 150
 151     return $author->books;
 152   };
 153
 154   my $rs;
 155   eval {
 156     $rs = $schema->txn_do($coderef);
 157   };
 158
 159   if ($@) {                                  # Transaction failed
 160     die "something terrible has happened!"   #
 161       if ($@ =~ /Rollback failed/);          # Rollback failed
 162
 163     deal_with_failed_transaction();
 164   }
 165
 166 In a nested transaction (calling txn_do() from within a txn_do() coderef) only
 167 the outermost transaction will issue a L</txn_commit>, and txn_do() can be
 168 called in void, scalar and list context and it will behave as expected.
 169
 170 Please note that all of the code in your coderef, including non-DBIx::Class
 171 code, is part of a transaction.  This transaction may fail out halfway, or
 172 it may get partially double-executed (in the case that our DB connection
 173 failed halfway through the transaction, in which case we reconnect and
 174 restart the txn).  Therefore it is best that any side-effects in your coderef
 175 are idempotent (that is, can be re-executed multiple times and get the
 176 same result), and that you check up on your side-effects in the case of
 177 transaction failure.
 178
 179 =cut
 180
 181 sub txn_do {
 182   my ($self, $coderef, @args) = @_;
 183
 184   ref $coderef eq 'CODE' or $self->throw_exception
 185     ('$coderef must be a CODE reference');
 186
 187   my (@return_values, $return_value);
 188
 189   $self->txn_begin; # If this throws an exception, no rollback is needed
 190
 191   my $wantarray = wantarray; # Need to save this since the context
 192                              # inside the eval{} block is independent
 193                              # of the context that called txn_do()
 194   eval {
 195
 196     # Need to differentiate between scalar/list context to allow for
 197     # returning a list in scalar context to get the size of the list
 198     if ($wantarray) {
 199       # list context
 200       @return_values = $coderef->(@args);
 201     } elsif (defined $wantarray) {
 202       # scalar context
 203       $return_value = $coderef->(@args);
 204     } else {
 205       # void context
 206       $coderef->(@args);
 207     }
 208     $self->txn_commit;
 209   };
 210
 211   if ($@) {
 212     my $error = $@;
 213
 214     eval {
 215       $self->txn_rollback;
 216     };
 217
 218     if ($@) {
 219       my $rollback_error = $@;
 220       my $exception_class = "DBIx::Class::Storage::NESTED_ROLLBACK_EXCEPTION";
 221       $self->throw_exception($error)  # propagate nested rollback
 222         if $rollback_error =~ /$exception_class/;
 223
 224       $self->throw_exception(
 225         "Transaction aborted: $error. Rollback failed: ${rollback_error}"
 226       );
 227     } else {
 228       $self->throw_exception($error); # txn failed but rollback succeeded
 229     }
 230   }
 231
 232   return $wantarray ? @return_values : $return_value;
 233 }
 234
 235 =head2 txn_begin
 236
 237 Starts a transaction.
 238
 239 See the preferred L</txn_do> method, which allows for
 240 an entire code block to be executed transactionally.
 241
 242 =cut
 243
 244 sub txn_begin { die "Virtual method!" }
 245
 246 =head2 txn_commit
 247
 248 Issues a commit of the current transaction.
 249
 250 =cut
 251
 252 sub txn_commit { die "Virtual method!" }
 253
 254 =head2 txn_rollback
 255
 256 Issues a rollback of the current transaction. A nested rollback will
 257 throw a L<DBIx::Class::Storage::NESTED_ROLLBACK_EXCEPTION> exception,
 258 which allows the rollback to propagate to the outermost transaction.
 259
 260 =cut
 261
 262 sub txn_rollback { die "Virtual method!" }
 263
 264 =head2 sql_maker
 265
 266 Returns a C<sql_maker> object - normally an object of class
 267 C<DBIC::SQL::Abstract>.
 268
 269 =cut
 270
 271 sub sql_maker { die "Virtual method!" }
 272
 273 =head2 debug
 274
 275 Causes trace information to be emitted on the C<debugobj> object.
 276 (or C<STDERR> if C<debugobj> has not specifically been set).
 277
 278 This is the equivalent to setting L</DBIC_TRACE> in your
 279 shell environment.
 280
 281 =head2 debugfh
 282
 283 Set or retrieve the filehandle used for trace/debug output.  This should be
 284 an IO::Handle compatible ojbect (only the C<print> method is used.  Initially
 285 set to be STDERR - although see information on the
 286 L<DBIC_TRACE> environment variable.
 287
 288 =cut
 289
 290 sub debugfh {
 291     my $self = shift;
 292
 293     if ($self->debugobj->can('debugfh')) {
 294         return $self->debugobj->debugfh(@_);
 295     }
 296 }
 297
 298 =head2 debugobj
 299
 300 Sets or retrieves the object used for metric collection. Defaults to an instance
 301 of L<DBIx::Class::Storage::Statistics> that is compatible with the original
 302 method of using a coderef as a callback.  See the aforementioned Statistics
 303 class for more information.
 304
 305 =head2 debugcb
 306
 307 Sets a callback to be executed each time a statement is run; takes a sub
 308 reference.  Callback is executed as $sub->($op, $info) where $op is
 309 SELECT/INSERT/UPDATE/DELETE and $info is what would normally be printed.
 310
 311 See L<debugobj> for a better way.
 312
 313 =cut
 314
 315 sub debugcb {
 316     my $self = shift;
 317
 318     if ($self->debugobj->can('callback')) {
 319         return $self->debugobj->callback(@_);
 320     }
 321 }
 322
 323 =head2 cursor_class
 324
 325 The cursor class for this Storage object.
 326
 327 =cut
 328
 329 =head2 deploy
 330
 331 Deploy the tables to storage (CREATE TABLE and friends in a SQL-based
 332 Storage class). This would normally be called through
 333 L<DBIx::Class::Schema/deploy>.
 334
 335 =cut
 336
 337 sub deploy { die "Virtual method!" }
 338
 339 =head2 connect_info
 340
 341 The arguments of C<connect_info> are always a single array reference,
 342 and are Storage-handler specific.
 343
 344 This is normally accessed via L<DBIx::Class::Schema/connection>, which
 345 encapsulates its argument list in an arrayref before calling
 346 C<connect_info> here.
 347
 348 =cut
 349
 350 sub connect_info { die "Virtual method!" }
 351
 352 =head2 select
 353
 354 Handle a select statement.
 355
 356 =cut
 357
 358 sub select { die "Virtual method!" }
 359
 360 =head2 insert
 361
 362 Handle an insert statement.
 363
 364 =cut
 365
 366 sub insert { die "Virtual method!" }
 367
 368 =head2 update
 369
 370 Handle an update statement.
 371
 372 =cut
 373
 374 sub update { die "Virtual method!" }
 375
 376 =head2 delete
 377
 378 Handle a delete statement.
 379
 380 =cut
 381
 382 sub delete { die "Virtual method!" }
 383
 384 =head2 select_single
 385
 386 Performs a select, fetch and return of data - handles a single row
 387 only.
 388
 389 =cut
 390
 391 sub select_single { die "Virtual method!" }
 392
 393 =head2 columns_info_for
 394
 395 Returns metadata for the given source's columns.  This
 396 is *deprecated*, and will be removed before 1.0.  You should
 397 be specifying the metadata yourself if you need it.
 398
 399 =cut
 400
 401 sub columns_info_for { die "Virtual method!" }
 402
 403 =head1 ENVIRONMENT VARIABLES
 404
 405 =head2 DBIC_TRACE
 406
 407 If C<DBIC_TRACE> is set then trace information
 408 is produced (as when the L<debug> method is set).
 409
 410 If the value is of the form C<1=/path/name> then the trace output is
 411 written to the file C</path/name>.
 412
 413 This environment variable is checked when the storage object is first
 414 created (when you call connect on your schema).  So, run-time changes
 415 to this environment variable will not take effect unless you also
 416 re-connect on your schema.
 417
 418 =head2 DBIX_CLASS_STORAGE_DBI_DEBUG
 419
 420 Old name for DBIC_TRACE
 421
 422 =head1 AUTHORS
 423
 424 Matt S. Trout <mst@shadowcatsystems.co.uk>
 425
 426 Andy Grundman <andy@hybridized.org>
 427
 428 =head1 LICENSE
 429
 430 You may distribute this code under the same terms as Perl itself.
 431
 432 =cut
 433
 434 1;