File Coverage

blib/lib/Bio/Gonzales/MiniFeat.pm

Criterion	Covered	Total	%
statement	83	100	83.0
branch	25	34	73.5
condition	13	18	72.2
subroutine	23	31	74.1
pod	0	19	0.0
total	144	202	71.2

package Bio::Gonzales::MiniFeat;
use strict;
use warnings;
use Carp;

use Mouse;
use List::MoreUtils qw/zip/;
use Data::Dumper;
use Storable qw(dclone);
use Scalar::Util qw/refaddr/;

our $QUIET_MODE;

our $VERSION = '0.083'; # VERSION

has type => ( is => 'rw', required => 1 );
has source => ( is => 'rw' );

has attributes => ( is => 'rw', default => sub { {} } );

has [qw/subfeats parentfeats/] => ( is => 'rw', default => sub { [] } );

sub attr { return shift->attributes(@_); }

sub clone {
  my ($self) = @_;

  my %data = %$self;
  $data{attributes} = dclone( $data{attributes} ) if ( exists( $data{attributes} ) );

  return __PACKAGE__->new( \%data );
}

sub _attr_single {
  my ( $self, $p ) = @_;
  $p = { name => $p } unless ( ref $p );

  confess "no attributes can be set with this method" if ( $p->{args} );
  return
    unless ( exists( $self->attributes->{ $p->{name} } ) && @{ $self->attributes->{ $p->{name} } } > 0 );
  carp "multiple ID entries, taking the first"
    if ( @{ $self->attributes->{ $p->{name} } } > 1 && !$p->{quiet} );
  return $self->attributes->{ $p->{name} }[0];
}

sub _attr_list {
  my ( $self, $attr, @values ) = @_;

  return
    unless ( exists( $self->attributes->{$attr} ) && @{ $self->attributes->{$attr} } > 0 );

  return wantarray ? @{ $self->attributes->{$attr} } : $self->attributes->{$attr}
    unless ( @values && @values > 0 );

  my $current_v = $self->attributes->{$attr};
  my $new_v;
  if ( @values == 1 && ref $values[0] eq 'ARRAY' ) {
    $self->attributes->{$attr} = $values[0];
  } else {
    $self->attributes->{$attr} = \@values;

  }
  return wantarray ? @{$current_v} : $current_v;
}

sub first_attr {
  my ( $self, $name ) = @_;
  return $self->_attr_single( { name => $name, quiet => 1 } );
}

sub attr_first { return shift->first_attr(@_); }

sub id { return shift->_attr_single( { name => 'ID' } ); }

sub ids { return shift->_attr_list( 'ID', @_ ); }

sub attr_list { return shift->_attr_list(shift); }

sub name { return shift->_attr_single( { name => 'Name' } ); }

sub parent_ids { return shift->_attr_list( 'Parent', @_ ); }

sub parent_id { return shift->_attr_single( { name => 'Parent' } ); }

sub attr_replace { return shift->replace_attr(@_) }

sub replace_attr {
  my ( $self, $name, @values ) = @_;

  confess "name cannot be a reference" if ( ref $name );
  return $self->_attr_list( $name, @values );
}

sub parents {
  confess 'use parent_ids';
}

sub parent {
  confess 'use parent_id';
}

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

  $sub = sub { return $_[0] }
    unless defined $sub;

  my %visited;
  return $self->_recurse_subfeats( \%visited, $sub, 1 );

}

sub _recurse_subfeats {
  my ( $self, $v, $sub, $depth ) = @_;

  if ( exists( $v->{ refaddr($self) } ) && $v->{ refaddr($self) } != $depth ) {
    confess "Recursion in subfeature retrieval in level $depth/"
      . $v->{ refaddr($self) } . "\n"
      . Dumper $self;
  }

  $v->{ refaddr($self) } = $depth;

  my @result;
  if ( @{ $self->subfeats } > 0 ) {
    $depth++;
    for my $sf ( @{ $self->subfeats } ) {
      push @result, $sub->( $sf, $depth );
      push @result, $sf->_recurse_subfeats( $v, $sub, $depth );
    }
  }

  return @result;
}

sub uniq {
  my ($self) = @_;

  $self->subfeats(    [ List::MoreUtils::uniq @{ $self->subfeats } ] );
  $self->parentfeats( [ List::MoreUtils::uniq @{ $self->parentfeats } ] );
}

sub add_attr {
  my ( $self, %attrs ) = @_;

  while ( my ( $name, $value ) = each %attrs ) {
    $self->attributes->{$name} = [] unless defined $self->attributes->{$name};
    push @{ $self->attributes->{$name} }, ( ref $value eq 'ARRAY' ? @$value : $value );
  }

  return;
}

sub has_attr {
  my ( $self, $name ) = @_;
  return exists( $self->attributes->{$name} );
}

sub del_attr {
  my ( $self, @names ) = @_;

  my @deleted;
  for my $name (@names) {
    push @deleted, delete $self->attributes->{$name};
  }
  return @names == 1 ? $deleted[0] : \@deleted;
}

1;