view release on metacpan or  search on metacpan

lib/Bio/MAGETAB/Util/Builder.pm  view on Meta::CPAN

# Copyright 2008-2010 Tim Rayner
# 
# This file is part of Bio::MAGETAB.
# 
# Bio::MAGETAB is free software: you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation, either version 2 of the License, or
# (at your option) any later version.
# 
# Bio::MAGETAB is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
# 
# 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: Builder.pm 351 2010-09-03 10:58:15Z tfrayner $

package Bio::MAGETAB::Util::Builder;

use Moose;
use MooseX::FollowPBP;

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

use Bio::MAGETAB;
use Carp;
use List::Util qw( first );
use English qw( -no_match_vars );

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

has 'namespace'           => ( is         => 'rw',
                               isa        => Str,
                               default    => q{},
                               required   => 1 );

has 'database'            => ( is         => 'rw',
                               isa        => HashRef,
                               default    => sub { {} },
                               required   => 1 );

has 'magetab'             => ( is         => 'ro',
                               isa        => 'Bio::MAGETAB',
                               default    => sub { Bio::MAGETAB->new() },
                               required   => 1 );

has 'relaxed_parser'      => ( is         => 'rw',
                               isa        => Bool,
                               default    => 0,
                               required   => 1 );

sub update {

    # Empty stub method; updates are not required when the objects are
    # all held in scope by the database hashref. This method is
    # overridden in persistence subclasses dealing with
    # e.g. relational databases.

    1;
}

sub _create_id {

    my ( $self, $class, $data, $id_fields ) = @_;

    unless ( first { defined $data->{ $_ } } @{ $id_fields } ) {
        my $allowed = join(', ', @{ $id_fields });
        confess(qq{Error: No identifying attributes for $class.}
              . qq{ Must use at least one of the following: $allowed.\n});
    }

    my $id = join(q{; }.chr(0), map { $data->{$_} || q{} } sort @{ $id_fields });

    # This really should never happen.
    unless ( $id ) {
        confess("Error: Null object ID in class $class.\n");
    }

    return $id;
}

sub _update_object_attributes {

    my ( $self, $obj, $data ) = @_;

    my $class = $obj->meta()->name();

    ATTR:
    while ( my ( $attr, $value ) = each %{ $data } ) {

        next ATTR unless ( defined $value );

        my $getter = "get_$attr";
        my $setter = "set_$attr";
        my $has_a  = "has_$attr";

        # Object either must have attr or has a predicate method.
        if( ! UNIVERSAL::can( $obj, $has_a ) || $obj->$has_a ) {

            my $attr_obj = $obj->meta->find_attribute_by_name( $attr );
            my $type = $attr_obj->type_constraint()->name();

            if ( $type =~ /\A ArrayRef/xms ) {
                if ( ref $value eq 'ARRAY' ) {
                    my @old = $obj->$getter;
                    foreach my $item ( @$value ) {
                         
                        # If this is a list attribute, add the new value.
                        unless ( first { $_ eq $item } @old ) {
                            push @old, $item;
                        }
                    }