lib/Bio/DB/GFF/Adaptor/dbi/caching_handle.pm

   1 package Bio::DB::GFF::Adaptor::dbi::caching_handle;
   2
   3 use strict;
   4 use DBI;
   5 use vars '$AUTOLOAD';
   6 use base qw(Bio::Root::Root);
   7
   8 =head1 NAME
   9
  10 Bio::DB::GFF::Adaptor::dbi::caching_handle -- Cache for database handles
  11
  12 =head1 SYNOPSIS
  13
  14  use Bio::DB::GFF::Adaptor::dbi::caching_handle;
  15  $db  = Bio::DB::GFF::Adaptor::dbi::caching_handle->new('dbi:mysql:test');
  16  $sth = $db->prepare('select * from foo');
  17  @h   = $sth->fetch_rowarray;
  18  $sth->finish
  19
  20 =head1 DESCRIPTION
  21
  22 This module handles a pool of database handles.  It was motivated by
  23 the MYSQL driver's {mysql_use_result} attribute, which dramatically
  24 improves query speed and memory usage, but forbids additional query
  25 statements from being evaluated while an existing one is in use.
  26
  27 This module is a plug-in replacement for vanilla DBI.  It
  28 automatically activates the {mysql_use_result} attribute for the mysql
  29 driver, but avoids problems with multiple active statement handlers by
  30 creating new database handles as needed.
  31
  32 =head1 USAGE
  33
  34 The object constructor is
  35 Bio::DB::GFF::Adaptor::dbi::caching_handle-E<gt>new().  This is called
  36 like DBI-E<gt>connect() and takes the same arguments.  The returned object
  37 looks and acts like a conventional database handle.
  38
  39 In addition to all the standard DBI handle methods, this package adds
  40 the following:
  41
  42 =head2 dbi_quote
  43
  44  Title   : dbi_quote
  45  Usage   : $string = $db->dbi_quote($sql,@args)
  46  Function: perform bind variable substitution
  47  Returns : query string
  48  Args    : the query string and bind arguments
  49  Status  : public
  50
  51 This method replaces the bind variable "?" in a SQL statement with
  52 appropriately quoted bind arguments.  It is used internally to handle
  53 drivers that don't support argument binding.
  54
  55 =head2 do_query
  56
  57  Title   : do_query
  58  Usage   : $sth = $db->do_query($query,@args)
  59  Function: perform a DBI query
  60  Returns : a statement handler
  61  Args    : query string and list of bind arguments
  62  Status  : Public
  63
  64 This method performs a DBI prepare() and execute(), returning a
  65 statement handle.  You will typically call fetch() of fetchrow_array()
  66 on the statement handle.  The parsed statement handle is cached for
  67 later use.
  68
  69 =head2 debug
  70
  71  Title   : debug
  72  Usage   : $debug = $db->debug([$debug])
  73  Function: activate debugging messages
  74  Returns : current state of flag
  75  Args    : optional new setting of flag
  76  Status  : public
  77
  78 =cut
  79
  80 sub new {
  81   my $class    = shift;
  82   my @dbi_args = @_;
  83   my $self = bless {
  84                     dbh    => [],
  85                     args   => \@dbi_args,
  86                     debug => 0,
  87                    },$class;
  88   $self->dbh || $self->throw("Can't connect to database: " . DBI->errstr);
  89   $self;
  90 }
  91
  92 sub AUTOLOAD {
  93   my($pack,$func_name) = $AUTOLOAD=~/(.+)::([^:]+)$/;
  94   return if $func_name eq 'DESTROY';
  95   my $self = shift or return DBI->$func_name(@_);
  96   $self->dbh->$func_name(@_);
  97 }
  98
  99 sub debug {
 100   my $self = shift;
 101   my $d = $self->{debug};
 102   $self->{debug} = shift if @_;
 103   $d;
 104 }
 105
 106 sub prepare {
 107   my $self  = shift;
 108   my $query = shift;
 109
 110   # find a non-busy dbh
 111   my $dbh = $self->dbh || $self->throw("Can't connect to database: " . DBI->errstr);
 112
 113   warn "Using prepare_cache\n" if $self->debug;
 114   my $sth = $dbh->prepare_cached($query, {}, 3) || $self->throw("Couldn't prepare query $query:\n ".DBI->errstr."\n");
 115   return $sth;
 116 }
 117
 118 sub do_query {
 119   my $self = shift;
 120   my ($query,@args) = @_;
 121   warn $self->dbi_quote($query,@args),"\n" if $self->debug;
 122   my $sth = $self->prepare($query);
 123   $sth->execute(@args) || $self->throw("Couldn't execute query $query:\n ".DBI->errstr."\n");
 124   $sth;
 125 }
 126
 127 sub dbh {
 128   my $self = shift;
 129   foreach (@{$self->{dbh}}) {
 130     return $_ if $_->inuse == 0;
 131   }
 132   # if we get here, we must create a new one
 133   warn "(Re)connecting to database\n" if $self->debug;
 134   my $dbh = DBI->connect(@{$self->{args}}) or return;
 135
 136   $dbh->{PrintError} = 0;
 137
 138   # for Oracle - to retrieve LOBs, need to define the length (Jul 15, 2002)
 139   $dbh->{LongReadLen} = 100*65535;
 140   $dbh->{LongTruncOk} = 0;
 141   $dbh->{mysql_auto_reconnect} = 1;
 142
 143   my $wrapper = Bio::DB::GFF::Adaptor::dbi::faux_dbh->new($dbh);
 144   push @{$self->{dbh}},$wrapper;
 145   $wrapper;
 146 }
 147
 148 # The clone method should only be called in child processes after a fork().
 149 # It does two things: (1) it sets the "real" dbh's InactiveDestroy to 1,
 150 # thereby preventing the database connection from being destroyed in
 151 # the parent when the dbh's destructor is called; (2) it replaces the
 152 # "real" dbh with the result of dbh->clone(), so that we now have an
 153 # independent handle.
 154 sub clone {
 155     my $self = shift;
 156     foreach (@{$self->{dbh}}) { $_->clone };
 157 }
 158
 159 =head2 attribute
 160
 161  Title   : attribute
 162  Usage   : $value = $db->attribute(AttributeName , [$newvalue])
 163  Function: get/set DBI::db handle attribute
 164  Returns : current state of the attribute
 165  Args    : name of the attribute and optional new setting of attribute
 166  Status  : public
 167
 168   Under Bio::DB::GFF::Adaptor::dbi::caching_handle the DBI::db
 169   attributes that are usually set using hashref calls are unavailable.
 170   Use attribute() instead.  For example, instead of:
 171
 172     $dbh->{AutoCommit} = 0;
 173
 174   use
 175
 176     $dbh->attribute(AutoCommit=>0);
 177
 178 =cut
 179
 180 sub attribute {
 181   my $self = shift;
 182   my $dbh = $self->dbh->{dbh};
 183   return $dbh->{$_[0]} = $_[1] if @_ == 2;
 184   return $dbh->{$_[0]}         if @_ == 1;
 185   return;
 186 }
 187
 188 sub disconnect {
 189   my $self = shift;
 190   $_ && $_->disconnect foreach @{$self->{dbh}};
 191   $self->{dbh} = [];
 192 }
 193
 194 sub dbi_quote {
 195   my $self = shift;
 196   my ($query,@args) = @_;
 197   my $dbh = $self->dbh;
 198   $query =~ s/\?/$dbh->quote(shift @args)/eg;
 199   $query;
 200 }
 201
 202 package Bio::DB::GFF::Adaptor::dbi::faux_dbh;
 203 use vars '$AUTOLOAD';
 204
 205 sub new {
 206   my $class = shift;
 207   my $dbh   = shift;
 208   bless {dbh=>$dbh},$class;
 209 }
 210
 211 sub prepare {
 212   my $self = shift;
 213   my $sth = $self->{dbh}->prepare(@_) or return;
 214   $sth->{mysql_use_result} = 1 if $self->{dbh}->{Driver}{Name} eq 'mysql';
 215   $sth;
 216 }
 217
 218 sub prepare_delayed {
 219   my $self = shift;
 220   my $sth = $self->{dbh}->prepare(@_) or return;
 221   $sth;
 222 }
 223
 224 sub inuse {
 225     shift->{dbh}->{ActiveKids};
 226 }
 227
 228 # The clone method should only be called in child processes after a fork().
 229 # It does two things: (1) it sets the "real" dbh's InactiveDestroy to 1,
 230 # thereby preventing the database connection from being destroyed in
 231 # the parent when the dbh's destructor is called; (2) it replaces the
 232 # "real" dbh with the result of dbh->clone(), so that we now have an
 233 # independent handle.
 234 sub clone {
 235     my $self = shift;
 236     $self->{dbh}{InactiveDestroy} = 1;
 237     $self->{dbh} = $self->{dbh}->clone;
 238 }
 239
 240 sub DESTROY { }
 241
 242 sub AUTOLOAD {
 243   my($pack,$func_name) = $AUTOLOAD=~/(.+)::([^:]+)$/;
 244   return if $func_name eq 'DESTROY';
 245   my $self = shift;
 246   if( defined $self->{dbh} ) {
 247       $self->{dbh}->$func_name(@_);
 248   }
 249 }
 250
 251 1;
 252
 253 __END__
 254
 255 =head1 BUGS
 256
 257 Report to the author.
 258
 259 =head1 SEE ALSO
 260
 261 L<DBI>, L<Bio::DB::GFF>, L<bioperl>
 262
 263 =head1 AUTHOR
 264
 265 Lincoln Stein E<lt>lstein@cshl.orgE<gt>.
 266
 267 Copyright (c) 2001 Cold Spring Harbor Laboratory.
 268
 269 This library is free software; you can redistribute it and/or modify
 270 it under the same terms as Perl itself.
 271
 272 =cut
 273