lib/Bio/DB/DBI/Transaction.pm

   1 # $Id$
   2 #
   3 # BioPerl module for Bio::DB::DBI::Transaction
   4 #
   5 # Please direct questions and support issues to <bioperl-l@bioperl.org>
   6 #
   7 # Cared for by Hilmar Lapp <hlapp at gmx.net>
   8 #
   9 # Copyright Hilmar Lapp
  10 #
  11 # You may distribute this module under the same terms as perl itself
  12
  13 #
  14 # (c) Hilmar Lapp, hlapp at gmx.net, 2003.
  15 # (c) GNF, Genomics Institute of the Novartis Research Foundation, 2003.
  16 #
  17 # You may distribute this module under the same terms as perl itself.
  18 # Refer to the Perl Artistic License (see the license accompanying this
  19 # software package, or see http://www.perl.com/language/misc/Artistic.html)
  20 # for the terms under which you may use, modify, and redistribute this module.
  21 #
  22 # THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED
  23 # WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF
  24 # MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE.
  25 #
  26
  27 # POD documentation - main docs before the code
  28
  29 =head1 NAME
  30
  31 Bio::DB::DBI::Transaction - DESCRIPTION of Object
  32
  33 =head1 SYNOPSIS
  34
  35 Give standard usage here
  36
  37 =head1 DESCRIPTION
  38
  39 Describe the object here
  40
  41 =head1 FEEDBACK
  42
  43 =head2 Mailing Lists
  44
  45 User feedback is an integral part of the evolution of this and other
  46 Bioperl modules. Send your comments and suggestions preferably to
  47 the Bioperl mailing list.  Your participation is much appreciated.
  48
  49   bioperl-l@bioperl.org                  - General discussion
  50   http://bioperl.org/wiki/Mailing_lists  - About the mailing lists
  51
  52 =head2 Support
  53
  54 Please direct usage questions or support issues to the mailing list:
  55
  56 I<bioperl-l@bioperl.org>
  57
  58 rather than to the module maintainer directly. Many experienced and
  59 reponsive experts will be able look at the problem and quickly
  60 address it. Please include a thorough description of the problem
  61 with code and data examples if at all possible.
  62
  63 =head2 Reporting Bugs
  64
  65 Report bugs to the Bioperl bug tracking system to help us keep track
  66 of the bugs and their resolution. Bug reports can be submitted via
  67 the web:
  68
  69   http://redmine.open-bio.org/projects/bioperl/
  70
  71 =head1 AUTHOR - Hilmar Lapp
  72
  73 Email hlapp at gmx.net
  74
  75 Describe contact details here
  76
  77 =head1 CONTRIBUTORS
  78
  79 Additional contributors names and emails here
  80
  81 =head1 APPENDIX
  82
  83 The rest of the documentation details each of the object methods.
  84 Internal methods are usually preceded with a _
  85
  86 =cut
  87
  88
  89 # Let the code begin...
  90
  91
  92 package Bio::DB::DBI::Transaction;
  93 use vars qw(@ISA);
  94 use strict;
  95 use Carp qw(confess);
  96
  97 # Object preamble - inherits from Bio::Root::Root
  98
  99 use Bio::Root::Root;
 100
 101 @ISA = qw(Bio::Root::Root );
 102
 103 my %transactions = ();
 104
 105 =head2 new
 106
 107  Title   : new
 108  Usage   :
 109  Function: This method throws an exception. Use get_Transaction()
 110            to get a Transaction object.
 111  Returns :
 112  Args    :
 113
 114
 115 =cut
 116
 117 sub new {
 118     my($class,@args) = @_;
 119
 120     confess "You cannot instantiate this class from outside. ".
 121         "Use get_Transaction() to get an object.";
 122 }
 123
 124 =head2 _new
 125
 126  Title   : _new
 127  Usage   : my $obj = Bio::DB::DBI::Transaction->_new();
 128  Function: Builds a new Bio::DB::DBI::Transaction object
 129
 130            This is a private method. If you call this method from
 131            outside you are on your own. Call get_Transaction() to
 132            obtain an instance of this class.
 133
 134  Returns : an instance of Bio::DB::DBI::Transaction
 135  Args    :
 136
 137
 138 =cut
 139
 140 sub _new {
 141     my($class,@args) = @_;
 142
 143     # silly trick but maybe catches some silly people who don't believe
 144     my $bummer = pop(@args);
 145     return $class->new($bummer, @args) unless $bummer && ($bummer eq "Bummer");
 146
 147     my $self = $class->SUPER::new(@args);
 148     return $self;
 149 }
 150
 151 =head2 dbh
 152
 153  Title   : dbh
 154  Usage   :
 155  Function: Get/set the database connection handle for this transaction.
 156            Transactions are connection-specific.
 157
 158            You should not need to call this method from outside. If
 159            you do, call yourself bold, but you're on your own ...
 160
 161  Example :
 162  Returns : A DBI database connection handle
 163  Args    : on set, the new DBI database connection handle
 164
 165
 166 =cut
 167
 168 sub dbh{
 169     my $self = shift;
 170
 171     return $self->{'dbh'} = shift if @_;
 172     return $self->{'dbh'};
 173 }
 174
 175 =head2 commit
 176
 177  Title   : commit
 178  Usage   :
 179  Function: Commit this transaction.
 180
 181            Read the DBI perldoc for $dbh->commit about possible
 182            return values and behaviour.
 183
 184            Committing the transaction will also notify all listeners
 185            before and after the actual commit. Listeners have the
 186            opportunity to veto a transaction commit by returning
 187            false from their before_commit() method.
 188
 189  Example :
 190  Returns : The return value from $dbh->commit()
 191  Args    : none
 192
 193
 194 =cut
 195
 196 sub commit{
 197     my $self = shift;
 198
 199     foreach my $listener ($self->get_TransactionListeners()) {
 200         if($listener->can("before_commit")) {
 201             $listener->before_commit() || return;
 202         }
 203     }
 204     my $rv = $self->dbh->commit();
 205     foreach my $listener ($self->get_TransactionListeners()) {
 206         $listener->after_commit() if $listener->can("after_commit");
 207     }
 208     return $rv;
 209 }
 210
 211 =head2 rollback
 212
 213  Title   : rollback
 214  Usage   :
 215  Function: Rollback this transaction.
 216
 217            Read the DBI perldoc for $dbh->rollback about possible
 218            return values and behaviour.
 219
 220            Rolling back the transaction will also notify all listeners
 221            before and after the actual rollback. Listeners cannot veto
 222            a transaction rollback.
 223
 224  Example :
 225  Returns : The return value from $dbh->rollback()
 226  Args    : none
 227
 228
 229 =cut
 230
 231 sub rollback{
 232     my $self = shift;
 233
 234     foreach my $listener ($self->get_TransactionListeners()) {
 235         eval {
 236             $listener->before_rollback() if $listener->can("before_rollback");
 237         };
 238         if($@) {
 239             $self->warn(ref($listener).
 240                         "::before_rollback threw an exception, but rollback ".
 241                         "cannot be vetoed (message was: ".$@.")");
 242         }
 243     }
 244     my $rv = $self->dbh->rollback();
 245     foreach my $listener ($self->get_TransactionListeners()) {
 246         $listener->after_rollback() if $listener->can("after_rollback");
 247     }
 248     return $rv;
 249 }
 250
 251 =head2 get_TransactionListeners
 252
 253  Title   : get_TransactionListeners
 254  Usage   : @arr = get_TransactionListeners()
 255  Function: Get the list of TransactionListener(s) for this object.
 256
 257            We currently do not enforce the listener objects to
 258            literally be Bio::DB::DBI::TransactionListener implementing
 259            objects. This object can handle this; use $obj->can() for
 260            every listener-specific call you invoke yourself on the
 261            returned objects.
 262
 263  Example :
 264  Returns : An array of Bio::DB::DBI::TransactionListener objects
 265  Args    :
 266
 267
 268 =cut
 269
 270 sub get_TransactionListeners{
 271     my $self = shift;
 272
 273     return @{$self->{'_listeners'}} if exists($self->{'_listeners'});
 274     return ();
 275 }
 276
 277 =head2 add_TransactionListener
 278
 279  Title   : add_TransactionListener
 280  Usage   :
 281  Function: Add one or more TransactionListener(s) to this object.
 282
 283            We currently do not enforce the listener objects to
 284            literally be Bio::DB::DBI::TransactionListener implementing
 285            objects.
 286
 287  Example :
 288  Returns :
 289  Args    : One or more Bio::DB::DBI::TransactionListener objects.
 290
 291
 292 =cut
 293
 294 sub add_TransactionListener{
 295     my $self = shift;
 296
 297     $self->{'_listeners'} = [] unless exists($self->{'_listeners'});
 298     push(@{$self->{'_listeners'}}, @_);
 299 }
 300
 301 =head2 remove_TransactionListeners
 302
 303  Title   : remove_TransactionListeners
 304  Usage   :
 305  Function: Remove all TransactionListeners for this class.
 306
 307            We currently do not enforce the listener objects to
 308            literally be Bio::DB::DBI::TransactionListener implementing
 309            objects. This object can handle this; use $obj->can() for
 310            every listener-specific call you invoke yourself on the
 311            returned objects.
 312
 313  Example :
 314  Returns : The list of previous TransactionListeners as an array of
 315            Bio::DB::DBI::TransactionListener objects.
 316  Args    :
 317
 318
 319 =cut
 320
 321 sub remove_TransactionListeners{
 322     my $self = shift;
 323
 324     my @arr = $self->get_TransactionListeners();
 325     $self->{'_listeners'} = [];
 326     return @arr;
 327 }
 328
 329 =head2 remove_TransactionListener
 330
 331  Title   : remove_TransactionListener
 332  Usage   :
 333  Function: Remove one TransactionListener for this class.
 334
 335            We currently do not enforce the listener objects to
 336            literally be Bio::DB::DBI::TransactionListener implementing
 337            objects. This object can handle this; use $obj->can() for
 338            every listener-specific call you invoke yourself on the
 339            returned objects.
 340
 341  Example :
 342  Returns : void
 343  Args    : A Bio::DB::DBI::TransactionListener object
 344
 345
 346 =cut
 347
 348 sub remove_TransactionListener{
 349     my $self = shift;
 350     my $obj = shift;
 351
 352     my @arr = grep { $_ != $obj } $self->remove_TransactionListeners();
 353     $self->{'_listeners'} = [@arr];
 354 }
 355
 356 =head2 get_Transaction
 357
 358  Title   : get_Transaction
 359  Usage   :
 360  Function: Get the Transaction for a particular connection.
 361
 362            This is a class method.
 363  Example :
 364  Returns : an instance of this class
 365  Args    : a DBI database connection handle for which to obtain
 366            the transaction
 367
 368            All other arguments are passed on to new() if a new
 369            Transaction needs to be created.
 370
 371
 372 =cut
 373
 374 sub get_Transaction{
 375     my $class = shift;
 376     my $dbh = shift;
 377     my $tx;
 378
 379     if(exists($transactions{$dbh})) {
 380         $tx = $transactions{$dbh};
 381     } else {
 382         $tx = $class->_new("Bummer",@_);
 383         $tx->dbh($dbh);
 384         $transactions{$dbh} = $tx;
 385     }
 386     return $tx;
 387 }
 388
 389 1;