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