File Coverage

blib/lib/Statistics/R/REXP.pm

Criterion	Covered	Total	%
statement	47	47	100.0
branch	32	34	94.1
condition	19	24	79.1
subroutine	13	13	100.0
pod	3	4	75.0
total	114	122	93.4

package Statistics::R::REXP;
# ABSTRACT: base class for R objects (Cs)
$Statistics::R::REXP::VERSION = '1.0001';
use 5.010;

use Scalar::Util qw( blessed );

use Class::Tiny::Antlers;

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

use overload
    eq => sub { shift->_eq(@_) },
    ne => sub { ! shift->_eq(@_) };


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

    die "This is an abstract class and must be subclassed" if ref($self) eq __PACKAGE__;

    # Required methods
    for my $req ( qw/sexptype to_pl/ ) {
        die "$req method required" unless $self->can($req);
    }

    # Required attribute type
    die "Attribute 'attributes' must be a hash reference" if defined $self->attributes &&
        ref($self->attributes) ne 'HASH'
}

sub _eq {
    my ($self, $obj) = (shift, shift);
    return undef unless _mutual_isa($self, $obj);

    my $a = $self->attributes;
    my $b = $obj->attributes;

    _compare_deeply($a, $b)
}


## Returns true if either argument is a subclass of the other
sub _mutual_isa {
    my ($a, $b) = (shift, shift);

    ref $a eq ref $b ||
        (blessed($a) && blessed($b) &&
         ($a->isa(ref $b) ||
          $b->isa(ref $a)))
}


sub _compare_deeply {
    my ($a, $b) = @_ or die 'Need two arguments';
    if (defined($a) and defined($b)) {
        return 0 unless _mutual_isa($a, $b);
        if (ref $a eq ref []) {
            return undef unless scalar(@$a) == scalar(@$b);
            for (my $i = 0; $i < scalar(@{$a}); $i++) {
                return undef unless _compare_deeply($a->[$i], $b->[$i]);
            }
        } elsif (ref $a eq ref {}) {
            return undef unless scalar(keys %$a) == scalar(keys %$b);
            foreach my $name (keys %$a) {
                return undef unless exists $b->{$name} &&
                    _compare_deeply($a->{$name}, $b->{$name});
            }
        } else {
            return undef unless $a eq $b;
        }
    } else {
        return undef if defined($a) or defined($b);
    }

    return 1;
}


sub is_null {
    return 0;
}


sub is_vector {
    return 0;
}


sub inherits {
    my ($self, $class) = @_;
    my $attributes = $self->attributes;
    return unless $attributes && $attributes->{'class'};

    grep {/^$class$/} @{$attributes->{'class'}->to_pl}
}

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

__END__