Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Fetching contributors…

Cannot retrieve contributors at this time

618 lines (467 sloc) 16.338 kB
# $Id$
#
# BioPerl module for Bio::DB::Persistent::PersistentObject
#
# Please direct questions and support issues to <bioperl-l@bioperl.org>
#
# Cared for by Hilmar Lapp <hlapp at gmx.net>
#
# Copyright Hilmar Lapp
#
# You may distribute this module under the same terms as perl itself
#
# (c) Hilmar Lapp, hlapp at gmx.net, 2002.
# (c) GNF, Genomics Institute of the Novartis Research Foundation, 2002.
#
# You may distribute this module under the same terms as perl itself.
# Refer to the Perl Artistic License (see the license accompanying this
# software package, or see http://www.perl.com/language/misc/Artistic.html)
# for the terms under which you may use, modify, and redistribute this module.
#
# THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED
# WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF
# MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE.
#
# POD documentation - main docs before the code
=head1 NAME
Bio::DB::Persistent::PersistentObject - makes a given object persistent
=head1 SYNOPSIS
# obtain a PersistentObject somehow, e.g.
$pobj = $dbadaptor->create_persistent("Bio::Seq");
# manipulate and query as if it were the wrapped object itself
print $pobj->isa("Bio::PrimarySeqI"), "\n";
$pobj->display_id("O238356");
$pobj->seq("ATCATCGACTGACAGGCAGTATCGACTAGCA");
$fea = Bio::SeqFeature::Generic->new(-start => 3, -end => 15);
$fea->attach_seq($pobj);
# and so on and so forth
# and, finally, or whenever suitable, make it persistent in the datastore
$pobj->create();
# change it
$pobj->desc("not a useful description");
# and update it in the datastore
$pobj->store();
# you may also want it to disappear
$pobj->remove();
=head1 DESCRIPTION
This class takes any Bioperl object for which an adaptor exists for a certain
datastore and makes it implement Bio::DB::PersistentObjectI.
There is one single caveat though. The wrapped object must not use any of the
method names defined in Bio::DB::PersistentObjectI, nor obj() or adaptor().
If it does, calls of these methods will never get routed to the wrapped object.
=head1 FEEDBACK
=head2 Mailing Lists
User feedback is an integral part of the evolution of this and other
Bioperl modules. Send your comments and suggestions preferably to
the Bioperl mailing list. Your participation is much appreciated.
bioperl-l@bioperl.org - General discussion
http://bioperl.org/wiki/Mailing_lists - About the mailing lists
=head2 Support
Please direct usage questions or support issues to the mailing list:
L<bioperl-l@bioperl.org>
rather than to the module maintainer directly. Many experienced and
reponsive experts will be able look at the problem and quickly
address it. Please include a thorough description of the problem
with code and data examples if at all possible.
=head2 Reporting Bugs
Report bugs to the Bioperl bug tracking system to help us keep track
of the bugs and their resolution. Bug reports can be submitted via
the web:
http://bugzilla.open-bio.org/
=head1 AUTHOR - Hilmar Lapp
Email hlapp at gmx.net
Describe contact details here
=head1 CONTRIBUTORS
Additional contributors names and emails here
=head1 APPENDIX
The rest of the documentation details each of the object methods.
Internal methods are usually preceded with a _
=cut
# Let the code begin...
package Bio::DB::Persistent::PersistentObject;
use vars qw(@ISA);
use strict;
use Scalar::Util qw(refaddr);
# Object preamble - inherits from Bio::Root::Root
use Bio::Root::Root;
use Bio::DB::PersistentObjectI;
@ISA = qw(Bio::Root::Root Bio::DB::PersistentObjectI);
our $AUTOLOAD;
our %wrapper_class_map = ();
=head2 new
Title : new
Usage : my $obj = Bio::DB::Persistent::PersistentObject->new();
Function: Builds a new Bio::DB::Persistent::PersistentObject object
Returns : an instance of Bio::DB::Persistent::PersistentObject
Args : -object => $obj_to_be_wrapped (mandatory)
-adaptor => $adaptor_for_obj (optional, may be set later)
=cut
sub new {
my ($class,@args) = @_;
$class = ref($class) if ref($class);
my %params = @args;
# obtain object to be wrapped and adaptor for datastore
my $obj = $params{'-object'};
$obj = $params{'-OBJECT'} unless defined($obj);
# if this package then try to load a specialized wrapper if one available
if(defined($obj) && $class eq "Bio::DB::Persistent::PersistentObject") {
my $wclass = $class->_load_persistence_wrapper(ref($obj) || $obj,
"Bio::DB::Persistent::");
return $wclass->new(@args) if $wclass;
}
# else instantiate here
my $self = $class->SUPER::new(@args);
# obtain adaptor for datastore
my $adp = $params{'-adaptor'} || $params{'-ADAPTOR'};
$self->obj($obj) if defined($obj);
$self->adaptor($adp) if defined($adp);
$self->is_dirty(1);
# success - we hope
return $self;
}
sub _load_persistence_wrapper{
my ($self,$class,$prefix,$suffix) = @_;
my $pmod;
$prefix = "" unless defined($prefix);
$suffix = "" unless defined($suffix);
# if not yet attempted to load the appropriate module
if(! exists($wrapper_class_map{$class})) {
# build persistence module name
$pmod = $class;
$pmod =~ s/.*://; # keep only first component
my @mods = ($pmod);
# try with and without capital I (interface)
if($pmod =~ s/^(.*)I$/$1/) {
push(@mods,$pmod);
}
foreach $pmod (map { $prefix . $_ . $suffix; } @mods) {
$self->debug("attempting to load class $pmod\n");
#print STDERR "attempting to load class $pmod\n";
eval {
$self->_load_module($pmod);
};
# mark success if success
if(! $@) {
$wrapper_class_map{$class} = $pmod;
last;
}
}
}
# return if success (now or previously)
return $wrapper_class_map{$class} if exists($wrapper_class_map{$class});
#
# otherwise recursively and depth-first traverse inheritance tree
#
# we need to bring in this class here in order to have access to @ISA.
eval {
$self->_load_module($class);
};
if($@) {
$self->throw("weird: cannot load class $class : ".$@);
}
my $aryname = "${class}::ISA"; # this is a soft reference
# hence, allow soft refs
no strict "refs";
my @ancestors = @$aryname;
# and disallow again
use strict "refs";
# loop over all ancestors; this is depth first traversal
$pmod = undef;
foreach my $ancestor (@ancestors) {
$pmod = $self->_load_persistence_wrapper($ancestor,
$prefix, $suffix);
last if $pmod;
}
$wrapper_class_map{$class} = $pmod; # may be undef and hence mark failure
# we don't throw an exception here -- not finding a class is perfectly
# legal
return $pmod;
}
=head2 create
Title : create
Usage : $obj->create()
Function: Creates the object as a persistent object in the datastore. This
is equivalent to an insert.
Note that you will be able to retrieve the primary key at any time
by calling primary_key() on the object.
Example :
Returns : The newly assigned primary key.
Args : Optionally, additional named parameters. A common parameter will
be -fkobjs, with a reference to an array of foreign key objects
that are not retrievable from the persistent object itself.
=cut
sub create{
my ($self,@args) = @_;
my $adp = $self->adaptor();
$self->throw("unable to carry out database operation without an adaptor")
unless $adp;
my $obj = $adp->create($self, @args);
$self->is_dirty(-1) if $obj && $obj->primary_key();
return $obj;
}
=head2 store
Title : store
Usage : $obj->store()
Function: Updates the persistent object in the datastore to reflect its
attribute values.
Example :
Returns : TRUE on success and FALSE otherwise
Args : Optionally, additional named parameters. A common parameter will
be -fkobjs, with a reference to an array of foreign key objects
that are not retrievable from the persistent object itself.
=cut
sub store{
my ($self,@args) = @_;
my $adp = $self->adaptor();
$self->throw("unable to carry out database operation without an adaptor")
unless $adp;
my $rv = 1;
$rv = $adp->store($self, @args);
$self->is_dirty(-1) if $rv;
return $rv;
}
=head2 remove
Title : remove
Usage : $obj->remove()
Function: Removes the persistent object from the datastore.
Example :
Returns : TRUE on success and FALSE otherwise
Args : none
=cut
sub remove{
my ($self,@args) = @_;
my $adp = $self->adaptor();
$self->throw("unable to carry out database operation without an adaptor")
unless $adp;
return $adp->remove($self, @args);
}
=head2 primary_key
Title : primary_key
Usage : $obj->primary_key($newval)
Function: Get the primary key of the persistent object in the datastore.
Note that this implementation does not permit changing the
primary key once it has been set. This is for sanity
reasons, and may or may not be relaxed in the future. The
only exception is changing it to undef.
Example :
Returns : value of primary_key (a scalar)
Args : new value (a scalar, optional)
=cut
sub primary_key{
my ($self,$value) = @_;
if((scalar(@_) == 2) && (! $value)) {
delete $self->{"_pk"};
} elsif($value) {
if(exists($self->{'_pk'}) && ($self->{'_pk'} != $value)) {
$self->throw("must not change primary_key() once it is set");
}
$self->{"_pk"} = $value;
}
return $self->{"_pk"};
}
=head2 obj
Title : obj
Usage : $obj->obj()
Function: Get/set the object that is made persistent through this adaptor.
Note that this implementation does not allow to change the
value once it has been set. This is for sanity reasons, and
may or may not be relaxed in the future.
Example :
Returns : The object made persistent through this adaptor
Args : On set, the new value. Read above for caveat.
=cut
sub obj{
my $self = shift;
my $obj = $self->{"_obj"};
if (@_) {
$obj = shift;
if (exists($self->{'_obj'})
&& (refaddr($obj) != refaddr($self->{'_obj'}))) {
$self->throw("must not change obj() once it is set");
}
$self->{"_obj"} = $obj;
}
# we must have the object to be wrapped
$self->throw("you must set the object to be wrapped before using it")
unless ref($obj);
return $obj;
}
=head2 adaptor
Title : adaptor
Usage : $obj->adaptor($newval)
Function: Get/set of the PersistenceAdaptorI compliant object that actually
implements persistence for this object
Example :
Returns : A Bio::DB::PersistenceAdaptorI compliant object
Args : Optionally, on set a Bio::DB::PersistenceAdaptorI compliant object
=cut
sub adaptor{
my $self = shift;
return $self->{'_adaptor'} = shift if @_;
return $self->{'_adaptor'};
}
=head2 is_dirty
Title : is_dirty
Usage : $obj->is_dirty($newval)
Function: Get/set whether this persistent object is to be considered
dirty.
An object is considered dirty if one or more of it's
properties has been altered since it was last obtained
from, stored in, or created in the database, or if the
create() (insert) or the last store() (update) hasn't been
committed or rolled back yet.
There are currently 3 known states of this attribute. A
value of zero (or false) means the object has not been
modified since it either came from the database, or since
the changes have been serialized (via store()) and
committed (via commit()). A negative value means changes
have been serialized, but not yet committed. A positive
value means there have been unserialized changes on the
object.
Example :
Returns : value of is_dirty (a scalar)
Args : on set, new value (a scalar or undef, optional)
=cut
sub is_dirty{
my $self = shift;
return $self->{'is_dirty'} = shift if @_;
return $self->{'is_dirty'};
}
=head1 Methods for transactional control
Rollback and commit
=cut
=head2 commit
Title : commit
Usage :
Function: Commits the current transaction, if the underlying driver
supports transactions.
Example :
Returns : TRUE
Args : none
=cut
sub commit{
my $self = shift;
my $rv = $self->adaptor->commit(@_);
$self->is_dirty(0) if ($self->is_dirty() < 0) && $rv;
return $rv;
}
=head2 rollback
Title : rollback
Usage :
Function: Triggers a rollback of the current transaction, if the
underlying driver supports transactions.
Example :
Returns : TRUE
Args : none
=cut
sub rollback{
my $self = shift;
my $rv = $self->adaptor->rollback(@_);
$self->is_dirty(1) if ($self->is_dirty() < 0) && $rv;
return $rv;
}
=head1 Methods to mimic the wrapped object
=cut
=head2 isa
Title : isa
Usage :
Function: This is a standard perl object method. We override it here in order
to generically claim we implement everything that the wrapped
object does.
Example :
Returns : TRUE if this object is an instance of the given class, or inherits
from the given class, and FALSE otherwise
Args : the class to query for (a scalar string)
=cut
sub isa{
my ($self,@args) = @_;
my $ans = $self->SUPER::isa(@args);
if(! $ans) {
# try the wrapped object, too, but not if it's self
my $obj = $self->obj();
$ans = $obj->isa(@args) unless refaddr($obj) == refaddr($self);
}
return $ans;
}
=head2 can
Title : can
Usage :
Function: This is a standard perl object method. We override it here in order
to generically claim we 'can' everything that the wrapped
object does.
Example :
Returns : TRUE if this object is has the named method, and FALSE otherwise
Args : the method to query for (a scalar string)
=cut
sub can{
my ($self,@args) = @_;
my $ans = $self->SUPER::can(@args);
if(! $ans) {
# try the wrapped object, too, but not if it's self
my $obj = $self->obj();
$ans = $obj->can(@args) unless refaddr($obj) == refaddr($self);
}
return $ans;
}
#
# This is private and does the magic in implementing the wrapped object's
# methods: it simply delegates all unresolved invocations to the wrapped
# object.
#
sub AUTOLOAD {
my ($self,@args) = @_;
# the method to call:
my $meth = $AUTOLOAD;
$meth =~ s/.*://;
# sanity check
if (! $self->isa("Bio::DB::Persistent::PersistentObject")) {
$self->throw("I'm an instance of ".ref($self)
.", not a persistent object instance! "
."(resolving $AUTOLOAD)");
}
# the object to delegate to:
my $obj = $self->obj();
# is the object set to which we delegate?
if ((!defined($obj)) || (refaddr($obj) == refaddr($self))) {
$self->throw("Can't locate object method \"$meth\" via package ".
ref($self));
}
# by default, we consider any arguments as a calling a setter and hence
# the object becomes dirty
$self->is_dirty(1) if @args;
# execute the method by delegation
return $obj->$meth(@args);
}
=head1 Implementation of the decorating methods
See L<Bio::DB::PersistentObjectI> for further documentation of the
methods.
=cut
=head2 rank
Title : rank
Usage : $obj->rank($newval)
Function: Get/set the rank of this persistent object in a 1:n or n:n
relationship.
Example :
Returns : value of rank (a scalar)
Args : new value (a scalar or undef, optional)
=cut
sub rank{
my $self = shift;
return $self->{'rank'} = shift if @_;
return $self->{'rank'};
}
=head2 foreign_key_slot
Title : foreign_key_slot
Usage : $obj->foreign_key_slot($newval)
Function: Get/set of the slot name that is referring to this persistent
object as a foreign key.
Example :
Returns : value of foreign_key_slot (a scalar)
Args : new value (a scalar or undef, optional)
=cut
sub foreign_key_slot{
my $self = shift;
return $self->{'_foreign_key_slot'} = shift if @_;
return $self->{'_foreign_key_slot'};
}
1;
Jump to Line
Something went wrong with that request. Please try again.