Bio::Phylo::Mediators::TaxaMediator - Mediator for links between taxa and other objects

Bio-Phylo documentation Contained in the Bio-Phylo distribution.

Index

Code Index:

NAME

Top

Bio::Phylo::Mediators::TaxaMediator - Mediator for links between taxa and other objects

SYNOPSIS

Top

 # no direct usage

DESCRIPTION

Top

This module manages links between taxon objects and other objects linked to them. It is an implementation of the Mediator design pattern (e.g. see http://www.atug.com/andypatterns/RM.htm, http://home.earthlink.net/~huston2/dp/mediator.html).

Methods defined in this module are meant only for internal usage by Bio::Phylo.

METHODS

Top

CONSTRUCTOR

new()

TaxaMediator constructor.

 Type    : Constructor
 Title   : new
 Usage   : my $mediator = Bio::Phylo::Taxa::TaxaMediator->new;
 Function: Instantiates a Bio::Phylo::Taxa::TaxaMediator
           object.
 Returns : A Bio::Phylo::Taxa::TaxaMediator object (singleton).
 Args    : None.

METHODS

register()

Stores argument in invocant's cache.

 Type    : Method
 Title   : register
 Usage   : $mediator->register( $obj );
 Function: Stores an object in mediator's cache
 Returns : $self
 Args    : An object, $obj
 Comments: This method is called every time an object is instantiated.
unregister()

Removes argument from invocant's cache.

 Type    : Method
 Title   : unregister
 Usage   : $mediator->unregister( $obj );
 Function: Cleans up mediator's cache of $obj and $obj's relations
 Returns : $self
 Args    : An object, $obj
 Comments: This method is called every time an object is destroyed.

Creates link between objects.

 Type    : Method
 Title   : set_link
 Usage   : $mediator->set_link( -one => $obj1, -many => $obj2 );
 Function: Creates link between objects
 Returns : $self
 Args    : -one  => $obj1 (source of a one-to-many relationship)
           -many => $obj2 (target of a one-to-many relationship)
 Comments: This method is called from within, for example, set_taxa
           method calls. A call like $taxa->set_matrix( $matrix ),
           and likewise a call like $matrix->set_taxa( $taxa ), are 
           both internally rerouted to:

           $mediator->set_link( 
                -one  => $taxa, 
                -many => $matrix 
           );

Retrieves link between objects.

 Type    : Method
 Title   : get_link
 Usage   : $mediator->get_link( 
               -source => $obj, 
               -type   => _CONSTANT_,
           );
 Function: Retrieves link between objects
 Returns : Linked object
 Args    : -source => $obj (required, the source of the link)
           -type   => a constant from Bio::Phylo::Util::CONSTANT

           (-type is optional, used to filter returned results in 
           one-to-many query).

 Comments: This method is called from within, for example, get_taxa
           method calls. A call like $matrix->get_taxa()
           and likewise a call like $forest->get_taxa(), are 
           both internally rerouted to:

           $mediator->get_link( 
               -source => $self # e.g. $matrix or $forest           
           );

           A call like $taxa->get_matrices() is rerouted to:

           $mediator->get_link( -source => $taxa, -type => _MATRIX_ );

Removes link between objects.

 Type    : Method
 Title   : remove_link
 Usage   : $mediator->remove_link( -one => $obj1, -many => $obj2 );
 Function: Removes link between objects
 Returns : $self
 Args    : -one  => $obj1 (source of a one-to-many relationship)
           -many => $obj2 (target of a one-to-many relationship)

           (-many argument is optional)

 Comments: This method is called from within, for example, 
           unset_taxa method calls. A call like $matrix->unset_taxa() 
           is rerouted to:

           $mediator->remove_link( -many => $matrix );

           A call like $taxa->unset_matrix( $matrix ); is rerouted to:

           $mediator->remove_link( -one => $taxa, -many => $matrix );

SEE ALSO

Top

Bio::Phylo::Manual

Also see the manual: Bio::Phylo::Manual and http://rutgervos.blogspot.com.

CITATION

Top

If you use Bio::Phylo in published research, please cite it:

Rutger A Vos, Jason Caravas, Klaas Hartmann, Mark A Jensen and Chase Miller, 2011. Bio::Phylo - phyloinformatic analysis using Perl. BMC Bioinformatics 12:63. http://dx.doi.org/10.1186/1471-2105-12-63

REVISION

Top

 $Id: TaxaMediator.pm 1660 2011-04-02 18:29:40Z rvos $
Bio-Phylo documentation Contained in the Bio-Phylo distribution. 
# $Id: TaxaMediator.pm 1660 2011-04-02 18:29:40Z rvos $
package Bio::Phylo::Mediators::TaxaMediator;
use strict;
use Scalar::Util qw'weaken';
use Bio::Phylo;
use Bio::Phylo::Util::Exceptions;

# XXX this class only has weak references
{
    my $logger = Bio::Phylo::get_logger();
    my $self;
    my ( @object, @relationship );


    sub new {

        # could be child class
        my $class = shift;

        # notify user
        $logger->info("constructor called for '$class'");

        # singleton class
        if ( not $self ) {
            $logger->debug("first time instantiation of singleton");
            $self = \$class;
            bless $self, $class;
        }
        return $self;
    }


    sub register {
        my ( $self, $obj ) = @_;
        my $id = $obj->get_id;

        # notify user
        $logger->info("registering object $obj ($id)");
        $object[$id] = $obj;
        weaken $object[$id];
        $logger->debug("done registering object $obj ($id)");
        return $self;
    }


    sub unregister {
        my ( $self, $obj ) = @_;

        # notify user
        #$logger->info("unregistering object '$obj'"); # XXX
        my $id = $obj->get_id;
        if ( defined $id ) {
            if ( exists $object[$id] ) {

                # one-to-many relationship
                if ( exists $relationship[$id] ) {
                    delete $relationship[$id];
                }
                else {

                    # one-to-one relationship
                  LINK_SEARCH: for my $relation (@relationship) {
                        if ( exists $relation->{$id} ) {
                            delete $relation->{$id};
                            last LINK_SEARCH;
                        }
                    }
                }
                delete $object[$id];
            }
        }
        return $self;
    }


    sub set_link {
        my $self = shift;
        my %opt  = @_;
        my ( $one, $many ) = ( $opt{'-one'}, $opt{'-many'} );
        my ( $one_id, $many_id ) = ( $one->get_id, $many->get_id );

        # notify user
        $logger->info("setting link between '$one' and '$many'");

        # delete any previously existing link
      LINK_SEARCH: for my $relation (@relationship) {
            if ( exists $relation->{$many_id} ) {
                delete $relation->{$many_id};

                # notify user
                $logger->info("deleting previous link");
                last LINK_SEARCH;
            }
        }

        # initialize new hash if not exist
        $relationship[$one_id] = {} if not $relationship[$one_id];
        my $relation = $relationship[$one_id];

        # value is type so that can retrieve in get_link
        $relation->{$many_id} = $many->_type;
        return $self;
    }


    sub get_link {
        my $self = shift;
        my %opt  = @_;
        my $id   = $opt{'-source'}->get_id;

        # have to get many objects
        if ( defined $opt{'-type'} ) {
            my $relation = $relationship[$id];
            return if not $relation;
            my @result;
            for my $key ( keys %{$relation} ) {
                push @result, $object[$key]
                  if $relation->{$key} == $opt{'-type'};
            }
            return \@result;
        }
        else {
          LINK_SEARCH: for my $i ( 0 .. $#relationship ) {
                my $relation = $relationship[$i];
                if ( exists $relation->{$id} ) {
                    return $object[$i];
                }
            }
        }
    }


    sub remove_link {
        my $self = shift;
        my %opt  = @_;
        my ( $one, $many ) = ( $opt{'-one'}, $opt{'-many'} );
        if ($one) {
            my $id       = $one->get_id;
            my $relation = $relationship[$id];
            return if not $relation;
            delete $relation->{ $many->get_id };
        }
        else {
            my $id = $many->get_id;
          LINK_SEARCH: for my $relation (@relationship) {
                if ( exists $relation->{$id} ) {
                    delete $relation->{$id};
                    last LINK_SEARCH;
                }
            }
        }
    }


}
1;