File Coverage

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

Criterion	Covered	Total	%
statement	43	44	97.7
branch	21	24	87.5
condition	12	21	57.1
subroutine	10	10	100.0
pod	1	3	33.3
total	87	102	85.2

package Statistics::R::REXP::Closure;
# ABSTRACT: an R closure
$Statistics::R::REXP::Closure::VERSION = '1.0';
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 => 'CLOSXP';

has args => (
    is => 'ro',
    default => sub { [] },
);

has defaults => (
    is => 'ro',
    default => sub { [] },
);

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

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


use overload
    '""' => sub {
        my $self = shift;
        'function('. join(', ', @{$self->args}) . ') ' . $self->body
    };


sub BUILDARGS {
    my $class = shift;
    if ( scalar @_ == 1 ) {
        if ( ref $_[0] eq 'HASH' ) {
            return $_[0];
        } elsif ( blessed $_[0] && $_[0]->isa('Statistics::R::REXP::Closure') ) {
            # copy constructor from another closure
            return { args => $_[0]->args,
                     defaults => $_[0]->defaults,
                     body => $_[0]->body,
                     environment => $_[0]->environment };
        }
        die "Single parameters to new() must be a HASH data"
            ." or a Statistics::R::REXP::Closure 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) = (shift, shift);

    # Required attribute
    die 'Attribute (body) is required' unless defined $args->{body};

    # Required attribute type
    die "Attribute 'args' must be a reference to an array of scalars" if ref($self->args) ne 'ARRAY' ||
        grep { ref $_ } @{$self->args};

    die "Attribute 'defaults' must be a reference to an array of REXPs" if ref($self->defaults) ne 'ARRAY' ||
        grep { defined($_) && ! (blessed($_) && $_->isa('Statistics::R::REXP')) } @{$self->defaults};

    die "Attribute 'body' must be a reference to an instance of Statistics::R::REXP" unless
        blessed($self->body) && $self->body->isa('Statistics::R::REXP');

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

    my $defaults_length = @{$self->defaults};
    if ($defaults_length) {
        die 'argument names don\'t match their defaults'
            unless $defaults_length == @{$self->args}
    }
}

around _eq => sub {
    my $orig = shift;
    return unless $orig->(@_);
    my ($self, $obj) = (shift, shift);
    Statistics::R::REXP::_compare_deeply($self->args, $obj->args) &&
        ((scalar(grep {$_} @{$self->defaults}) == scalar(grep {$_} @{$obj->defaults})) ||
         Statistics::R::REXP::_compare_deeply($self->defaults, $obj->defaults)) &&
        Statistics::R::REXP::_compare_deeply($self->body, $obj->body) &&
        Statistics::R::REXP::_compare_deeply($self->environment, $obj->environment)
};


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


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

__END__