Raw content of Bio::DB::GFF::Adaptor::dbi::caching_handle package Bio::DB::GFF::Adaptor::dbi::caching_handle; use strict; use DBI; use Bio::Root::Root; use vars '$AUTOLOAD','@ISA'; @ISA = qw(Bio::Root::Root); =head1 NAME Bio::DB::GFF::Adaptor::dbi::caching_handle -- Cache for database handles =head1 SYNOPSIS use Bio::DB::GFF::Adaptor::dbi::caching_handle; $db = Bio::DB::GFF::Adaptor::dbi::caching_handle->new('dbi:mysql:test'); $sth = $db->prepare('select * from foo'); @h = $sth->fetch_rowarray; $sth->finish =head1 DESCRIPTION This module handles a pool of database handles. It was motivated by the MYSQL driver's {mysql_use_result} attribute, which dramatically improves query speed and memory usage, but forbids additional query statements from being evaluated while an existing one is in use. This module is a plug-in replacement for vanilla DBI. It automatically activates the {mysql_use_result} attribute for the mysql driver, but avoids problems with multiple active statement handlers by creating new database handles as needed. =head1 USAGE The object constructor is Bio::DB::GFF::Adaptor::dbi::caching_handle-E<gt>new(). This is called like DBI-E<gt>connect() and takes the same arguments. The returned object looks and acts like a conventional database handle. In addition to all the standard DBI handle methods, this package adds the following: =head2 dbi_quote Title : dbi_quote Usage : $string = $db->dbi_quote($sql,@args) Function: perform bind variable substitution Returns : query string Args : the query string and bind arguments Status : public This method replaces the bind variable "?" in a SQL statement with appropriately quoted bind arguments. It is used internally to handle drivers that don't support argument binding. =head2 do_query Title : do_query Usage : $sth = $db->do_query($query,@args) Function: perform a DBI query Returns : a statement handler Args : query string and list of bind arguments Status : Public This method performs a DBI prepare() and execute(), returning a statement handle. You will typically call fetch() of fetchrow_array() on the statement handle. The parsed statement handle is cached for later use. =head2 debug Title : debug Usage : $debug = $db->debug([$debug]) Function: activate debugging messages Returns : current state of flag Args : optional new setting of flag Status : public =cut sub new { my $class = shift; my @dbi_args = @_; my $self = bless { dbh => [], args => \@dbi_args, debug => 0, },$class; $self->dbh || $self->throw("Can't connect to database: " . DBI->errstr); $self; } sub AUTOLOAD { my($pack,$func_name) = $AUTOLOAD=~/(.+)::([^:]+)$/; return if $func_name eq 'DESTROY'; my $self = shift or return DBI->$func_name(@_); $self->dbh->$func_name(@_); } sub debug { my $self = shift; my $d = $self->{debug}; $self->{debug} = shift if @_; $d; } sub prepare { my $self = shift; my $query = shift; # find a non-busy dbh my $dbh = $self->dbh || $self->throw("Can't connect to database: " . DBI->errstr); if (my $sth = $self->{$dbh}{$query}) { warn "Using cached statement handler\n" if $self->debug; return $sth; } else { warn "Creating new statement handler\n" if $self->debug; $sth = $dbh->prepare($query) || $self->throw("Couldn't prepare query $query:\n ".DBI->errstr."\n"); return $self->{$dbh}{$query} = $sth; } } sub do_query { my $self = shift; my ($query,@args) = @_; warn $self->dbi_quote($query,@args),"\n" if $self->debug; my $sth = $self->prepare($query); $sth->execute(@args) || $self->throw("Couldn't execute query $query:\n ".DBI->errstr."\n"); $sth; } sub dbh { my $self = shift; foreach (@{$self->{dbh}}) { return $_ if $_->inuse == 0; } # if we get here, we must create a new one warn "(Re)connecting to database\n" if $self->debug; my $dbh = DBI->connect(@{$self->{args}}) or return; $dbh->{PrintError} = 0; # for Oracle - to retrieve LOBs, need to define the length (Jul 15, 2002) $dbh->{LongReadLen} = 100*65535; $dbh->{LongTruncOk} = 0; my $wrapper = Bio::DB::GFF::Adaptor::dbi::faux_dbh->new($dbh); push @{$self->{dbh}},$wrapper; $wrapper; } =head2 attribute Title : attribute Usage : $value = $db->attribute(AttributeName , [$newvalue]) Function: get/set DBI::db handle attribute Returns : current state of the attribute Args : name of the attribute and optional new setting of attribute Status : public Under Bio::DB::GFF::Adaptor::dbi::caching_handle the DBI::db attributes that are usually set using hashref calls are unavailable. Use attribute() instead. For example, instead of: $dbh->{AutoCommit} = 0; use $dbh->attribute(AutoCommit=>0); =cut sub attribute { my $self = shift; my $dbh = $self->dbh->{dbh}; return $dbh->{$_[0]} = $_[1] if @_ == 2; return $dbh->{$_[0]} if @_ == 1; return; } sub disconnect { my $self = shift; $_ && $_->disconnect foreach @{$self->{dbh}}; $self->{dbh} = []; } sub dbi_quote { my $self = shift; my ($query,@args) = @_; my $dbh = $self->dbh; $query =~ s/\?/$dbh->quote(shift @args)/eg; $query; } package Bio::DB::GFF::Adaptor::dbi::faux_dbh; use vars '$AUTOLOAD'; sub new { my $class = shift; my $dbh = shift; bless {dbh=>$dbh},$class; } sub prepare { my $self = shift; my $sth = $self->{dbh}->prepare(@_) or return; $sth->{mysql_use_result} = 1 if $self->{dbh}->{Driver}{Name} eq 'mysql'; $sth; } sub prepare_delayed { my $self = shift; my $sth = $self->{dbh}->prepare(@_) or return; $sth; } sub inuse { shift->{dbh}->{ActiveKids}; } sub DESTROY { } sub AUTOLOAD { my($pack,$func_name) = $AUTOLOAD=~/(.+)::([^:]+)$/; return if $func_name eq 'DESTROY'; my $self = shift; if( defined $self->{dbh} ) { $self->{dbh}->$func_name(@_); } } 1; __END__ =head1 BUGS Report to the author. =head1 SEE ALSO L<DBI>, L<Bio::DB::GFF>, L<bioperl> =head1 AUTHOR Lincoln Stein E<lt>lstein@cshl.orgE<gt>. Copyright (c) 2001 Cold Spring Harbor Laboratory. This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut