Bio-Phylo
view release on metacpan or search on metacpan
lib/Bio/Phylo.pm view on Meta::CPAN
package Bio::Phylo;
use strict;
use warnings;
use Bio::PhyloRole;
use base 'Bio::PhyloRole';
# don't use Scalar::Util::looks_like_number directly, use wrapped version
use Scalar::Util qw'weaken blessed';
use Bio::Phylo::Util::CONSTANT '/looks_like/';
use Bio::Phylo::Util::IDPool; # creates unique object IDs
use Bio::Phylo::Util::Exceptions 'throw'; # defines exception classes and throws
use Bio::Phylo::Util::Logger; # for logging, like log4perl/log4j
use Bio::Phylo::Util::MOP; # for traversing inheritance trees
use Bio::Phylo::Identifiable; # for storing unique IDs inside an instance
our ( $logger, $COMPAT ) = Bio::Phylo::Util::Logger->new;
use version 0.77; our $VERSION = qv("v2.0.1");
lib/Bio/Phylo.pm view on Meta::CPAN
$class = $reference;
}
# happens only and exactly once because this
# root class is visited from every constructor
my $self = $class->SUPER::new();
# register for get_obj_by_id
my $id = $self->get_id;
$objects{$id} = $self;
weaken( $objects{$id} );
# notify user
$logger->info("constructor called for '$class' - $id");
# processing arguments
if ( @_ and @_ = looks_like_hash @_ ) {
$logger->info("processing arguments");
# process all arguments
ARG: while (@_) {
lib/Bio/Phylo.pm view on Meta::CPAN
=cut
sub _set_container {
my ( $self, $container ) = @_;
my $id = $self->get_id;
if ( blessed $container ) {
if ( $container->can('can_contain') ) {
if ( $container->can_contain($self) ) {
if ( $container->contains($self) ) {
$container{$id} = $container;
weaken( $container{$id} );
}
else {
throw 'ObjectMismatch' => "'$self' not in '$container'";
}
}
else {
throw 'ObjectMismatch' =>
"'$container' cannot contain '$self'";
}
}
lib/Bio/Phylo/Forest/Node.pm view on Meta::CPAN
package Bio::Phylo::Forest::Node;
use strict;
use warnings;
use Bio::Phylo::Forest::DrawNodeRole;
use base qw'Bio::Phylo::Forest::DrawNodeRole';
use Bio::Phylo::Util::CONSTANT qw':objecttypes /looks_like/';
use Bio::Phylo::Util::Exceptions 'throw';
use Scalar::Util 'weaken';
# store type constant
my ( $TYPE_CONSTANT, $CONTAINER_CONSTANT ) = ( _NODE_, _TREE_ );
{
# @fields array necessary for object destruction
my @fields = \( my ( %branch_length, %parent, %tree, %rank ) );
=head1 NAME
lib/Bio/Phylo/Forest/Node.pm view on Meta::CPAN
in the L<Bio::Phylo::Forest::NodeRole> package.
=head1 METHODS
=cut
my $set_raw_parent = sub {
my ( $self, $parent ) = @_;
my $id = $self->get_id;
$parent{$id} = $parent; # XXX here we modify parent
weaken $parent{$id} if $parent;
};
my $get_parent = sub {
my $self = shift;
return $parent{ $self->get_id };
};
my $get_children = sub { shift->get_entities };
my $get_branch_length = sub {
my $self = shift;
return $branch_length{ $self->get_id };
};
lib/Bio/Phylo/Forest/Node.pm view on Meta::CPAN
trees.
=cut
sub set_tree : Clonable {
my ( $self, $tree ) = @_;
my $id = $self->get_id;
if ($tree) {
if ( looks_like_object $tree, $CONTAINER_CONSTANT ) {
$tree{$id} = $tree;
weaken $tree{$id};
}
else {
throw 'ObjectMismatch' => "$tree is not a tree";
}
}
else {
$tree{$id} = undef;
}
return $self;
}
lib/Bio/Phylo/Forest/NodeRole.pm view on Meta::CPAN
use strict;
use warnings;
use Bio::Phylo::Util::MOP;
use base qw'Bio::Phylo::Taxa::TaxonLinker Bio::Phylo::Listable';
use Bio::Phylo::Util::OptionalInterface 'Bio::Tree::NodeI';
use Bio::Phylo::Util::CONSTANT qw':objecttypes /looks_like/';
use Bio::Phylo::Util::Exceptions 'throw';
use Bio::Phylo::Util::Math ':all';
use Bio::Phylo::NeXML::Writable;
use Bio::Phylo::Factory;
use Scalar::Util 'weaken';
use List::Util qw[sum min max];
no warnings 'recursion';
my $LOADED_WRAPPERS = 0;
# store type constant
my ( $TYPE_CONSTANT, $CONTAINER_CONSTANT ) = ( _NODE_, _TREE_ );
# logger singleton
my $logger = __PACKAGE__->get_logger;
lib/Bio/Phylo/Mediators/TaxaMediator.pm view on Meta::CPAN
package Bio::Phylo::Mediators::TaxaMediator;
use strict;
use warnings;
use Scalar::Util qw'weaken isweak';
use Bio::Phylo::Util::Logger ':simple';
use Bio::Phylo::Util::Exceptions;
use Bio::Phylo::Util::CONSTANT ':objecttypes';
{
my $self;
my ( @object, %id_by_type, %one_to_one, %one_to_many );
=head1 NAME
lib/Bio/Phylo/Mediators/TaxaMediator.pm view on Meta::CPAN
# node, forest, matrix, datum, taxon, taxa
if ( $type == _NODE_ || $type == _TAXON_ || $type == _DATUM_ || $type == _TAXA_ || $type == _FOREST_ || $type == _MATRIX_ ) {
# index by type
$id_by_type{$type} = {} unless $id_by_type{$type};
$id_by_type{$type}->{$id} = 1;
# store in object cache
$object[$id] = $obj;
# in the one-to-many relationships we only weaken the
# references to the many objects so that the get cleaned up
#Êwhen they go out of scope. When the are unregistered and
#Êthere is no more many object that references the one object,
# the one object's reference needs to be weakened as well so
# that it is cleaned up when it is no longer reachable from
# elsewhere.
#if ( $type != _TAXA_ && $type != _TAXON_ ) {
weaken $object[$id];
#}
return $self;
}
}
}
=item unregister()
Removes argument from invocant's cache.
lib/Bio/Phylo/Mediators/TaxaMediator.pm view on Meta::CPAN
my $id = $obj->get_id;
if ( defined $id ) {
my $taxa_id = $one_to_one{$id};
# decrease reference count of taxa block if we are the last pointer
# to it
if ( $taxa_id ) {
my @others = keys %{ $one_to_many{$taxa_id} };
if ( @others == 1 ) {
weaken $object[$taxa_id];
}
delete $one_to_many{$taxa_id}->{$id};
}
# remove from object cache
if ( exists $object[$id] ) {
delete $object[$id];
}
# remove from one-to-one mapping
lib/Bio/Phylo/Mediators/TaxaMediator.pm view on Meta::CPAN
my $self = shift;
my %opt = @_;
my ( $one, $many ) = ( $opt{'-one'}, $opt{'-many'} );
my ( $one_id, $many_id ) = ( $one->get_id, $many->get_id );
$one_to_one{$many_id} = $one_id;
$one_to_many{$one_id} = {} unless $one_to_many{$one_id};
# once other objects start referring to the taxon we want
# these references to keep the taxon "alive" until all other
# objects pointing to it have gone out of scope, in which
# case the reference must be weakened again, so that it
# might get cleaned up also
if (isweak($object[$one_id]) ) {
my $strong = $object[$one_id];
$object[$one_id] = $strong;
}
$one_to_many{$one_id}->{$many_id} = $many->_type;
return $self;
}
t/47-clone.t view on Meta::CPAN
"shallow clone delegates to same reference" );
ok( $taxa->get_id == $shallow->get_taxa->get_id,
"shallow clone delegates to same reference");
# characters and taxa were also cloned
ok( $matrix->get_characters->get_id != $deep->get_characters->get_id,
"deep clone delegates to different reference" );
# this previously didn't work because the implicitly created taxa block
# was immediately unreachable so it was cleaned up. we now keep the
# pointer from matrix to taxa unweakened so this doesn't happen and the
# test passes.
ok( $taxa->get_id != $deep->get_taxa->get_id,
"deep clone delegates to different reference" );
ok( $deep->get_taxa->get_ntax == 2, "same number of taxa" );
ok( $deep->get_taxa->first->get_id != $taxa->first->get_id, "different object IDs" );
ok( $shallow->get_taxa->first->get_id == $taxa->first->get_id, "same object IDs" );
# test if properties were cloned
ok( $matrix->get_characters->get_name eq $shallow->get_characters->get_name,
"shallow clone has same delegated object properties");
( run in 0.393 second using v1.01-cache-2.11-cpan-65fba6d93b7 )