3 # BioPerl module for Bio::DB::DBI::base
5 # Cared for by Hilmar Lapp <hlapp at gmx.net>
7 # Copyright Hilmar Lapp
9 # You may distribute this module under the same terms as perl itself
12 # (c) Hilmar Lapp, hlapp at gmx.net, 2002.
13 # (c) GNF, Genomics Institute of the Novartis Research Foundation, 2002.
15 # You may distribute this module under the same terms as perl itself.
16 # Refer to the Perl Artistic License (see the license accompanying this
17 # software package, or see http://www.perl.com/language/misc/Artistic.html)
18 # for the terms under which you may use, modify, and redistribute this module.
20 # THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED
21 # WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF
22 # MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE.
25 # POD documentation - main docs before the code
29 Bio::DB::DBI::base - base class for drivers implementing Bio::DB::DBI
33 Don't instantiate this module directly. Instead instantiate one of the
40 User feedback is an integral part of the evolution of this and other
41 Bioperl modules. Send your comments and suggestions preferably to the
42 Bioperl mailing list. Your participation is much appreciated.
44 bioperl-l@bioperl.org - General discussion
45 http://bioperl.org/wiki/Mailing_lists - About the mailing lists
49 Report bugs to the Bioperl bug tracking system to help us keep track
50 of the bugs and their resolution. Bug reports can be submitted via
53 http://bugzilla.open-bio.org/
55 =head1 AUTHOR - Hilmar Lapp
57 Email hlapp at gmx.net
59 Describe contact details here
63 Juguang Xiao, juguang at tll.org.sg
67 The rest of the documentation details each of the object methods.
68 Internal methods are usually preceded with a _
73 # Let the code begin...
76 package Bio
::DB
::DBI
::base
;
81 # Object preamble - inherits from Bio::Root::Root
85 @ISA = qw(Bio::Root::Root Bio::DB::DBI);
91 Function: should only be called by derived classes
93 Args : named parameters with tags -dbcontext (a Bio::DB::DBContextI
94 implementing object) and -sequence_name (the name of the sequence
101 my($class,@args) = @_;
103 my $self = $class->SUPER::new
(@args);
105 my ($dbc, $seqname) = $self->_rearrange([qw(DBCONTEXT SEQUENCE_NAME)],
108 $self->{'_dbh_pools'} = {};
109 $self->{'_conn_params'} = {};
110 $dbc && $self->dbcontext($dbc);
111 $self->sequence_name($seqname) if defined($seqname);
118 Title : sequence_name
119 Usage : $obj->sequence_name($newval)
120 Function: Sets/Gets the name of the sequence to be used for PK generation if
121 that name is not passed to the respective method as an argument.
123 Returns : value of sequence_name (a scalar)
124 Args : new value (a scalar, optional)
130 my ($self,$value) = @_;
131 if( defined $value) {
132 $self->{'sequence_name'} = $value;
134 return $self->{'sequence_name'};
141 Function: Constructs the DSN string from the DBContextI object. Since this
142 may be driver-specific, specific implementations may need to
143 override this method.
145 Returns : a string (the DSN)
146 Args : a Bio::DB::DBContextI implementing object
152 my ($self,$dbc) = @_;
154 my $dsn = $dbc->dsn();
155 if (! defined($dsn)) {
156 $dsn = "DBI:" . $dbc->driver() . ":database=" . $dbc->dbname();
157 $dsn .= ";host=" . $dbc->host() if $dbc->host();
158 $dsn .= ";port=" . $dbc->port() if $dbc->port();
163 =head2 get_connection
165 Title : get_connection
167 Function: Obtains a connection handle to the database represented by
168 the the DBContextI object, passing additional args to the
169 DBI->connect() method if a new connection is created.
171 Contrary to new_connection(), this method will return
172 shared connections from a pool. The implementation makes
173 sure though that the returned handle was opened with the
176 In addition, the caller must not disconnect the obtained
177 handle deliberately. Instead, the implementing object will
178 disconnect and dispose of open handles once it is being
179 garbage collected, or once disconnect() is called with the
180 same or no parameters.
182 Specific drivers usually won''t need to override this
183 method but rather build_dsn().
185 This implementation will call new_connection() to actually
186 get a new connection if needed.
189 Returns : an open DBI database handle
190 Args : A Bio::DB::DBContextI implementing object. Additional hashref
191 parameter to be passed to DBI->connect().
197 my ($self,$dbc,$params) = @_;
199 # The below line is added by Juguang.
200 # Well, I cannot see why the dbc needs to be re-assigned here again.
201 $dbc ||= $self->dbcontext;
203 my @keyvalues = $params ?
%$params : ("default");
204 # note that in the end the key doesn't carry meaning any more; the goal is
205 # rather to ensure that two invocations with the same dbcontext object and
206 # a hashref containing the same keys and values result in the same key
207 my $poolkey = "$dbc" . join(";", sort(@keyvalues));
209 if(! exists($self->{'_dbh_pools'}->{$poolkey})) {
210 $self->{'_dbh_pools'}->{$poolkey} = [];
213 my $connpool = $self->{'_dbh_pools'}->{$poolkey};
215 push(@
$connpool, $self->new_connection($dbc,$params));
217 return $connpool->[0];
220 =head2 new_connection
222 Title : new_connection
224 Function: Obtains a new connection handle to the database represented by the
225 the DBContextI object, passing additional args to the DBI->connect()
228 This method is supposed to always open a new connection. Also, the
229 implementing class is expected to release proper disconnection of
230 the handle entirely to the caller.
232 Specific drivers usually won''t need to override this method but
235 Returns : an open DBI database handle
236 Args : A Bio::DB::DBContextI implementing object. Additional hashref
237 parameter to pass to DBI->connect().
243 my ($self,$dbc,$params) = @_;
245 $self->throw("mandatory argument dbcontext not supplied (internal error?)")
247 my $dsn = $self->build_dsn($dbc);
248 $self->debug("new_connection(): dsn=$dsn; user=" . (defined $dbc->username() ?
$dbc->username() : 'undef') ."\n"); # undef: postgres 'ident sameuser' login
252 $dbh = DBI
->connect($dsn, $dbc->username(), $dbc->password(), $params);
254 if ($@
|| (! $dbh)) {
255 $self->throw("failed to open connection: " . $DBI::errstr
);
264 Function: Disconnects all or a certain number of connections matching the
265 parameters. The connections affected are those previously obtained
266 through get_connection() (shared connections from a pool).
269 Args : Optionally, a Bio::DB::DBContextI implementing object.
270 Additional hashref parameter with settings that were passed to
277 my ($self,$dbc,$params) = @_;
281 # disconnect all pools that we have
282 map { push(@connpools, $_); } (values %{$self->{'_dbh_pools'}});
284 my @keyvalues = $params ?
%$params : ("default");
285 # note that in the end the key doesn't carry meaning any more; the goal
286 # is rather to ensure that two invocations with the same dbcontext
287 # object and a hashref containing the same keys and values result in
289 my $poolkey = "$dbc" . join(";", sort(@keyvalues));
290 if(exists($self->{'_dbh_pools'}->{$poolkey})) {
291 push(@connpools, $self->{'_dbh_pools'}->{$poolkey});
294 # do they actual disconnection
295 foreach my $cpool (@connpools) {
297 my $dbh = shift(@
$cpool);
298 next unless $dbh; # during DESTROY there are indeed undef values --
299 # I have no idea where they come from
301 $self->_remove_idsths($dbh);
304 $self->warn("error while closing connection: ".$@
) if $@
;
312 Usage : $dbi->conn_params($requestor, $newval)
313 Function: Gets/sets connection parameters suitable for the specific
314 driver and the specific requestor.
316 A particular implementation may choose to ignore the
317 requestor, but it may also use it to return different
318 parameters, based on, e.g., which interface the requestor
319 implements. Usually the caller will pass $self as the value
320 $requestor, but an implementation is expected to accept
321 a class or interface name as well.
324 Returns : a hashref to be passed to get_connection() or new_connection()
325 (which would pass it on to DBI->connect()).
326 Args : The requesting object, or alternatively its class name or
328 Optionally, on set the new value (which must be undef or a
335 my ($self,$req,$params) = @_;
336 my $reqclass = ref($req) || $req;
338 if( defined $params) {
339 $self->{'_conn_params'}->{$reqclass} = $params;
341 # we try the class directly first
342 if(exists($self->{'_conn_params'}->{$reqclass})) {
343 $params = $self->{'_conn_params'}->{$reqclass};
345 # for an object, try whether we have something for an interface
347 foreach my $parent (keys %{$self->{'_conn_params'}}) {
348 if($req->isa($parent)) {
349 $params = $self->{'_conn_params'}->{$parent};
354 $params = {} unless $params; # default is empty hash
362 Usage : $obj->_idsth($newval)
363 Function: Get/set the last/next id value statement handle from/to
366 Consider this method 'protected' in OO-speak. I.e., call it
367 from derived modules, but not from outside.
370 Returns : a last_id_value or next_id_value prepared statement, or all
371 statements cached under the database handle if the key literal
373 Args : the database handle for which to cache the statement,
374 a key literal to distinguish between statements (e.g.,
376 and optionall on set the statement handle to cache
382 my ($self,$dbh,$key) = @_;
384 $self->{'_idsth_$dbh'} = {} unless exists($self->{'_idsth_$dbh'});
385 return values %{$self->{'_idsth_$dbh'}} unless $key;
386 return $self->{'_idsth_$dbh'}->{$key} = shift if @_;
387 return $self->{'_idsth_$dbh'}->{$key};
390 =head2 _remove_idsths
392 Title : _remove_idsths
394 Function: Un-caches all prepared statement handles cached under the
397 Returns : the list of previously cached statement handles
398 Args : the database handle
404 my ($self,$dbh) = @_;
406 return () unless exists($self->{'_idsth_$dbh'});
407 my @sths = values %{$self->{'_idsth_$dbh'}};
408 delete $self->{'_idsth_$dbh'};
416 $self->SUPER::DESTROY
;
421 $self->{_dbcontext
}=shift if @_;
422 return $self->{_dbcontext
};