File Coverage

blib/lib/Statistics/R/REXP/Environment.pm

Criterion	Covered	Total	%
statement	33	34	97.0
branch	12	14	85.7
condition	12	18	66.6
subroutine	11	11	100.0
pod	2	4	50.0
total	70	81	86.4

package Statistics::R::REXP::Environment;
# ABSTRACT: an R environment
$Statistics::R::REXP::Environment::VERSION = '1.0002';
use 5.010;

use Scalar::Util qw(refaddr blessed);

use Class::Tiny::Antlers qw(-default around);
use namespace::clean;

extends 'Statistics::R::REXP';

use constant sexptype => 'ENVSXP';

has frame => (
    is => 'ro',
    default => sub {
        { }
    },
);

has enclosure => (
    is => 'ro',
);


use overload
    '""' => sub { 'environment '. shift->name };


sub BUILDARGS {
    my $class = shift;
    if ( scalar @_ == 1 ) {
        if ( ref $_[0] eq 'HASH' ) {
            return $_[0];
        } elsif ( blessed $_[0] && $_[0]->isa('Statistics::R::REXP::Environment') ) {
            # copy constructor from another environment
            return { frame => $_[0]->frame,
                     enclosure => $_[0]->enclosure };
        }
        die "Single parameters to new() must be a HASH data"
            ." or a Statistics::R::REXP::Environment object => ". $_[0] ."\n";
    }
    elsif ( @_ % 2 ) {
        die "The new() method for $class expects a hash reference or a key/value list."
                . " You passed an odd number of arguments\n";
    }
    else {
        return {@_};
    }
}


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

    # Required attribute type
    die "Attribute 'frame' must be a reference to a hash of REXPs" if ref($self->frame) ne 'HASH' ||
        grep { ! (blessed($_) && $_->isa('Statistics::R::REXP')) } values(%{$self->frame});

    die "Attribute 'enclosure' must be an instance of Environment" if defined $self->enclosure &&
        !(blessed($self->enclosure) && $self->enclosure->isa('Statistics::R::REXP::Environment'));
}


around _eq => sub {
    my $orig = shift;
    return unless $orig->(@_);
    my ($self, $obj) = (shift, shift);
    Statistics::R::REXP::_compare_deeply($self->frame, $obj->frame) &&
        Statistics::R::REXP::_compare_deeply($self->enclosure, $obj->enclosure)
};


sub name {
    my $self = shift;
    ($self->attributes && exists $self->attributes->{name}) ?
        $self->attributes->{name} :
        '0x' . sprintf('%x', refaddr $self)
}


sub to_pl {
    die "Environments do not have a native Perl representation"
}


1; # End of Statistics::R::REXP::Environment

__END__