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