Bio-MAGETAB

 view release on metacpan or  search on metacpan

lib/Bio/MAGETAB/BaseClass.pm  view on Meta::CPAN

# along with Bio::MAGETAB.  If not, see <http://www.gnu.org/licenses/>.
#
# $Id: BaseClass.pm 340 2010-07-23 13:19:27Z tfrayner $

package Bio::MAGETAB::BaseClass;

use Moose;
use MooseX::FollowPBP;

use Carp;
use Scalar::Util qw(weaken);

use MooseX::Types::Moose qw( Str );

has 'authority'           => ( is         => 'rw',
                               isa        => Str,
                               clearer    => 'clear_authority',
                               predicate  => 'has_authority',
                               default    => q{},
                               required   => 1 );

lib/Bio/MAGETAB/BaseClass.pm  view on Meta::CPAN

        unless ( UNIVERSAL::can( $self, $getter ) ) {
            confess("ERROR: Unrecognised parameter: $param");
        }
    }

    if ( blessed $self eq __PACKAGE__ ) {
        confess("ERROR: Attempt to instantiate abstract class " . __PACKAGE__);
    }

    if ( my $container = __PACKAGE__->get_ClassContainer() ) {
        weaken $self;
        $container->add_objects( $self );
    }

    return;
}

{   # This is a class variable pointing to the container object with
    # which, when set, instantiated BaseClass objects will register.

    my $container;

lib/Bio/MAGETAB/Node.pm  view on Meta::CPAN

# You should have received a copy of the GNU General Public License
# along with Bio::MAGETAB.  If not, see <http://www.gnu.org/licenses/>.
#
# $Id: Node.pm 340 2010-07-23 13:19:27Z tfrayner $

package Bio::MAGETAB::Node;

use Moose;
use MooseX::FollowPBP;

use Scalar::Util qw(weaken);
use List::Util qw(first);

use MooseX::Types::Moose qw( ArrayRef );

BEGIN { extends 'Bio::MAGETAB::BaseClass' };

# This is an abstract class; block direct instantiation.
sub BUILD {

    my ( $self, $params ) = @_;

lib/Bio/MAGETAB/Node.pm  view on Meta::CPAN

# relationships are maintained, even when updating object attributes.
sub _reciprocate_edges_to_nodes {

    # $edges:       The edges with which $self has a reciprocal relationship.
    # $edge_slot:   The name of the slot pointing from $edge to $self.
    my ( $self, $edges, $edge_slot ) = @_;

    # Make sure $edges points to us. Since Edge->Node is 1..* we can
    # just overwrite the node attribute in the edges without worrying
    # about what else it might have pointed to. The Edge-to-Node
    # association is weakened to break a cicular reference on object
    # destruction.
    weaken $self;
    foreach my $t ( @$edges ) {
        $t->{ $edge_slot } = $self;
    }

    return;
}

# This method is used as a wrapper to ensure that reciprocating
# relationships are maintained, even when updating object attributes.
sub _reciprocate_sdrf_rows_to_nodes {

lib/Bio/MAGETAB/SDRFRow.pm  view on Meta::CPAN

# You should have received a copy of the GNU General Public License
# along with Bio::MAGETAB.  If not, see <http://www.gnu.org/licenses/>.
#
# $Id: SDRFRow.pm 340 2010-07-23 13:19:27Z tfrayner $

package Bio::MAGETAB::SDRFRow;

use Moose;
use MooseX::FollowPBP;

use Scalar::Util qw(weaken);
use List::Util qw(first);

use MooseX::Types::Moose qw( Int ArrayRef );

BEGIN { extends 'Bio::MAGETAB::BaseClass' };

sub BUILD {

    my ( $self, $params ) = @_;

lib/Bio/MAGETAB/SDRFRow.pm  view on Meta::CPAN

# This method is used as a wrapper to ensure that reciprocating
# relationships are maintained, even when updating object attributes.
sub _reciprocate_nodes_to_sdrf_rows {

    # $node:        The node with which $self has a reciprocal relationship.
    # $node_slot:   The name of the slot pointing from $node to $self.
    my ( $self, $nodes, $node_slot ) = @_;

    my $node_getter = "get_$node_slot";

    # The Node-to-Row association is weakened to break a cicular
    # reference on object destruction.
    weaken $self;

    # Make sure $rows points to us.
    foreach my $t ( $self->get_nodes() ) {
        my @current = $t->$node_getter();
        unless ( first { $_ eq $self } @current ) {
            push @current, $self;
            $t->{ $node_slot } = \@current;
        }
    }

t/003_edge.t  view on Meta::CPAN

# N.B. we don't bother testing the reciprocal deletion-on-set, because
# a node repointing to a new edge will break the old edge (since both
# input and output are required on an edge). This is a fairly bad
# state of affairs to get into, and it's assumed for now that any
# developer doing this must know what they're doing. FIXME we need a
# note in the docs to this effect (i.e. always update via Edge if
# you're remodelling your graph).

# This should live, and allow garbage collection to destroy both the
# edge and any protocol apps attached to it. The edge still references
# $ex2, but the ref is weakened. This is okay because edges don't have
# multiple outputNodes etc. and so aren't really reusable. FIXME
# consider removing the edge object from any Bio::MAGETAB container,
# though.
lives_ok( sub{ $ex2->clear_inputEdges() }, 'attempt to disconnect edges from node succeeds' );