File Coverage

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

Criterion	Covered	Total	%
statement	30	30	100.0
branch	8	10	80.0
condition	7	12	58.3
subroutine	10	10	100.0
pod	1	2	50.0
total	56	64	87.5

package Statistics::R::REXP::S4;
# ABSTRACT: an R closure
$Statistics::R::REXP::S4::VERSION = '1.0';
use 5.010;

use Scalar::Util qw(blessed);

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

extends 'Statistics::R::REXP';


use constant sexptype => 'S4SXP';

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

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

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

use overload
    '""' => sub { shift->_to_s };

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

    # Required attribute
    die "Attribute 'class' is required" unless defined $args->{class};

    # Required attribute type
    die "Attribute 'class' must be a scalar value" unless defined($self->class) && !ref($self->class);

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

    die "Attribute 'package' must be a scalar value" unless defined($self->package) && !ref($self->package);
}

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

sub _to_s {
    my $self = shift;

    "object of class '" . $self->class . "' (package " . $self->package . ") with " .
        scalar(keys(%{$self->slots})) . " slots"
}

sub to_pl {
    my $self = shift;

    { class => $self->class, slots => $self->slots, package => $self->package }
}

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

__END__