Archive Ensembl HomeArchive Ensembl Home
TagAdaptor.pm
Go to the documentation of this file.
00001 =head1 LICENSE
00002 
00003   Copyright (c) 1999-2012 The European Bioinformatics Institute and
00004   Genome Research Limited.  All rights reserved.
00005 
00006   This software is distributed under a modified Apache license.
00007   For license details, please see
00008 
00009    http://www.ensembl.org/info/about/code_licence.html
00010 
00011 =head1 CONTACT
00012 
00013   Please email comments or questions to the public Ensembl
00014   developers list at <dev@ensembl.org>.
00015 
00016   Questions may also be sent to the Ensembl help desk at
00017   <helpdesk@ensembl.org>.
00018 
00019 =head1 NAME
00020 
00021 Bio::EnsEMBL::Compara::DBSQL::TagAdaptor
00022 
00023 =head1 DESCRIPTION
00024 
00025 Generic adaptor that gives a database backend for tags / attributes (to
00026 use with Bio::EnsEMBL::Compara::Taggable). There can be any number of
00027 values for tags, but at most one for each attribute.
00028 
00029 =head1 MAINTAINER
00030 
00031 $Author: kb3 $
00032 
00033 =head VERSION
00034 
00035 $Revision: 1.9 $
00036 
00037 =head1 APPENDIX
00038 
00039 The rest of the documentation details each of the object methods.
00040 Internal methods are usually preceded with a _
00041 
00042 =cut
00043 
00044 package Bio::EnsEMBL::Compara::DBSQL::TagAdaptor;
00045 
00046 use strict;
00047 
00048 #use Data::Dumper;
00049 
00050 =head2 _tag_capabilities
00051 
00052   Description: returns the tag/attributes capabilities for the object. The
00053                return value is an array with 4 entries:
00054                 - the name of the table to store tag
00055                 - the name of the table to store attribute
00056                 - the name of the key column in the tables
00057                 - the name of the perl method to have the key value
00058   Arg [1]    : <scalar> reference object
00059   Example    : return ("species_set_tag", undef, "species_set_id", "dbID");
00060   Returntype : Array of 4 entries
00061   Exceptions : none
00062   Caller     : internal
00063 
00064 =cut
00065 
00066 sub _tag_capabilities {
00067     my ($self, $object) = @_;
00068 
00069     die "_tag_capabilities for $object must be redefined in $self (or a subclass)\n";
00070     #return ("protein_tree_tag", "protein_tree_attr", "node_id", "node_id");
00071 }
00072 
00073 
00074 =head2 _load_tagvalues
00075 
00076   Description: retrieves all the tags and attributes from the database and
00077                calls add_tag to store them in the PERL hash
00078   Arg [1]    : <scalar> reference object
00079   Example    : $genetree_adaptor->_load_tagvalues($tree);
00080   Returntype : none
00081   Exceptions : none
00082   Caller     : internal
00083 
00084 =cut
00085 
00086 sub _load_tagvalues {
00087     my $self = shift;
00088     my $object = shift;
00089 
00090     #print STDERR "CALL _load_tagvalues $self/$object\n";
00091     my ($db_tagtable, $db_attrtable, $db_keyname, $perl_keyname) = $self->_tag_capabilities($object);
00092     #print STDERR "_load_tagvalues = $db_tagtable/$db_attrtable\n";
00093  
00094     # Tags (multiple values are allowed)
00095     my $sth = $self->prepare("SELECT tag, value FROM $db_tagtable WHERE $db_keyname=?");
00096     $sth->execute($object->$perl_keyname);
00097     while (my ($tag, $value) = $sth->fetchrow_array()) {
00098         $object->add_tag($tag, $value, 1);
00099     }
00100     $sth->finish;
00101    
00102     # Attributes ?
00103     if (defined $db_attrtable) {
00104         # Attributes (multiple values are forbidden)
00105         $sth = $self->prepare("SELECT * FROM $db_attrtable WHERE $db_keyname=?");
00106         $sth->execute($object->$perl_keyname);
00107         # Retrieve data
00108         my $attrs = $sth->fetchrow_hashref();
00109         if (defined $attrs) {
00110             foreach my $key (keys %$attrs) {
00111                 if (($key ne $db_keyname) and defined(${$attrs}{$key})) {
00112                     $object->add_tag($key, ${$attrs}{$key});
00113                 }
00114             }
00115         }
00116         $sth->finish;
00117     }
00118 }
00119 
00120 
00121 =head2 _read_attr_list
00122 
00123   Description: retrieves the column names of an attribute table
00124   Arg [1]    : <scalar> table name
00125   Example    : $genetree_adaptor->_read_attr_list('protein_tree_node_attr');
00126   Returntype : none
00127   Exceptions : none
00128   Caller     : internal
00129 
00130 =cut
00131 
00132 sub _read_attr_list {
00133     my $self = shift;
00134     my $db_attrtable = shift;
00135 
00136     # No table provided
00137     return if not defined $db_attrtable;
00138     # Column names already loaded
00139     return if exists $self->{"_attr_list_$db_attrtable"};
00140 
00141     $self->{"_attr_list_$db_attrtable"} = {};
00142     eval {
00143         my $sth = $self->dbc->db_handle->column_info(undef, undef, $db_attrtable, '%');
00144         $sth->execute();
00145         while (my $row = $sth->fetchrow_hashref()) {
00146             ${$self->{"_attr_list_$db_attrtable"}}{${$row}{'COLUMN_NAME'}} = 1;
00147             #print STDERR "adding ", ${$row}{'COLUMN_NAME'}, " to the attribute list $db_attrtable of adaptor $self\n";
00148         }
00149         $sth->finish;
00150     };
00151     if ($@) {
00152         warn "$db_attrtable not available in this database\n";
00153     }
00154     #print STDERR "adaptor $self: ", Dumper($self);
00155 }
00156 
00157 
00158 =head2 _store_tagvalue
00159 
00160   Arg [1]    : <scalar> object
00161   Arg [2]    : <string> tag
00162   Arg [3]    : <string> value
00163   Arg [4]    : (optional) <int> allows overloading the tag with different values
00164                default is 0 (no overloading allowed, one tag points to one value)
00165   Example    : $speciesset_adaptor->_store_tagvalue($species_set, "colour", "red");
00166   Returntype : none
00167   Exceptions : none
00168   Caller     : internal
00169 
00170 =cut
00171 
00172 sub _store_tagvalue {
00173     my $self = shift;
00174     my $object = shift;
00175     my $tag = shift;
00176     my $value = shift;
00177     my $allow_overloading = shift;
00178     
00179     my ($db_tagtable, $db_attrtable, $db_keyname, $perl_keyname) = $self->_tag_capabilities($object);
00180     $self->_read_attr_list($db_attrtable);
00181     #print STDERR "CALL _store_tagvalue $self/$object/$tag: ", Dumper($self->{"_attr_list_$db_attrtable"});
00182   
00183     if (defined $db_attrtable && exists $self->{"_attr_list_$db_attrtable"}->{$tag}) {
00184         #print STDERR "attr\n";
00185         warn "Trying to overload the value of attribute '$tag' ! This is not allowed for $self\n" if $allow_overloading;
00186         # It is an attribute
00187         my $sth = $self->prepare("INSERT IGNORE INTO $db_attrtable ($db_keyname) VALUES (?)");
00188         $sth->execute($object->$perl_keyname);
00189         $sth->finish;
00190         $sth = $self->prepare("UPDATE $db_attrtable SET $tag=? WHERE $db_keyname=?");
00191         $sth->execute($value, $object->$perl_keyname);
00192         $sth->finish;
00193 
00194     } elsif ($allow_overloading) {
00195         #print STDERR "tag+\n";
00196         # It is a tag with multiple values allowed
00197         my $sth = $self->prepare("INSERT IGNORE INTO $db_tagtable ($db_keyname, tag, value) VALUES (?, ?, ?)");
00198         $sth->execute($object->$perl_keyname, $tag, $value);
00199         $sth->finish;
00200     } else {
00201         #print STDERR "tag\n";
00202         # It is a tag with only one value allowed
00203         my $sth = $self->prepare("DELETE FROM $db_tagtable WHERE $db_keyname=? AND tag=?");
00204         $sth->execute($object->$perl_keyname, $tag);
00205         $sth->finish;
00206         $sth = $self->prepare("INSERT INTO $db_tagtable ($db_keyname, tag, value) VALUES (?, ?, ?)");
00207         $sth->execute($object->$perl_keyname, $tag, $value);
00208         $sth->finish;
00209     }
00210 }
00211 
00212 
00213 =head2 _delete_tagvalue
00214 
00215   Description: removes a tag from the database
00216   Arg [1]    : <scalar> object
00217   Arg [2]    : <string> tag
00218   Arg [3]    : (optional) <string> value
00219   Example    : $speciesset_adaptor->_delete_tagvalue($species_set, "colour");
00220   Returntype : none
00221   Exceptions : none
00222   Caller     : internal
00223 
00224 =cut
00225 
00226 sub _delete_tagvalue {
00227     my $self = shift;
00228     my $object = shift;
00229     my $tag = shift;
00230     my $value = shift;
00231     
00232     my ($db_tagtable, $db_attrtable, $db_keyname, $perl_keyname) = $self->_tag_capabilities($object);
00233     $self->_read_attr_list($db_attrtable);
00234   
00235     if (exists $self->{"_attr_list_$db_attrtable"}->{$tag}) {
00236         # It is an attribute
00237         my $sth = $self->prepare("UPDATE $db_attrtable SET $tag=NULL WHERE $db_keyname=?");
00238         $sth->execute($object->$perl_keyname);
00239         $sth->finish;
00240 
00241     } else {
00242         # It is a tag
00243         if (defined $value) {
00244             my $sth = $self->prepare("DELETE FROM $db_tagtable WHERE $db_keyname=? AND tag=? AND value=?");
00245             $sth->execute($object->$perl_keyname, $tag, $value);
00246             $sth->finish;
00247         } else {
00248             my $sth = $self->prepare("DELETE FROM $db_tagtable WHERE $db_keyname=? AND tag=?");
00249             $sth->execute($object->$perl_keyname, $tag);
00250             $sth->finish;
00251         }
00252     }
00253 }
00254 
00255 
00256 =head2 sync_tags_to_database
00257 
00258   Description: rewrites all the tags from memory to the database
00259   Arg [1]    : <scalar> object
00260   Example    : $speciesset_adaptor->sync_tags_to_database($species_set);
00261   Returntype : none
00262   Exceptions : none
00263   Caller     : general
00264 
00265 =cut
00266 
00267 sub sync_tags_to_database {
00268     my $self = shift;
00269     my $object = shift;
00270 
00271     # To load the tags from the database
00272     my $hash = $object->get_tagvalue_hash();
00273     foreach my $tag (keys %$hash) {
00274 
00275         # Wipe out any previous value
00276         $self->_delete_tagvalue($object, $tag);
00277 
00278         # Write the new one(s)
00279         my $val = ${$hash}{$tag};
00280         if (ref($val) eq 'ARRAY') {
00281             foreach my $value (@$val) {
00282                 $self->_store_tagvalue($object, $tag, $value, 1);
00283             }
00284         } else {
00285             $self->_store_tagvalue($object, $tag, $val, 0);
00286         }
00287     }
00288 }
00289 
00290 1;