use strict;
# Test PDL Subclassing via hashes
########### First test normal subclassing ###########
{
package PDL::Derived;
our @ISA = qw/PDL/;
sub new {
my $class = shift;
bless {PDL=>shift, SomethingElse=>42}, $class;
}
}
# Create a PDL::Derived instance
my $z = PDL::Derived->new( ones(5,5) ) ;
# PDL::Derived should have PDL properties
$z++;
ok(sum($z)==50, "derived object does PDL stuff");
# And should also have extra bits
ok($$z{SomethingElse}==42, "derived has extra bits" );
# And survive destruction
undef $z;
########### Now test magic subclassing i.e. PDL=code ref ###########
{
package PDL::Derived2;
# This is a array of ones of dim 'Coeff'
# All that is stored initially is "Coeff", the
# PDL array is only realised when a boring PDL
# function is called on it. One can imagine methods
# in PDL::Derived2 doing manipulation on the Coeffs
# rather than actualizing the data.
our @ISA = qw/PDL/;
sub new {
my $class = shift;
bless {Coeff=>shift, PDL=>\&cache, SomethingElse=>42}, $class;
}
# Actualize the value (demonstrating cacheing)
# One can imagine expiring the cache if say, Coeffs change
sub cache {
my $self = shift;
return $self->{Cache} if exists $self->{Cache};
$self->{Cache} = PDL->ones(@$self{qw(Coeff Coeff)})+2;
}
}
# Create a PDL::Derived2 instance
$z = PDL::Derived2->new(5);
# PDL::Derived2 should have PDL properties
$z++;
ok(sum($z)==100, "derived2 has PDL properties");
# And should also have extra bits
ok($$z{SomethingElse}==42, "derived2 has extra bits" );
# And survive destruction
undef $z;
### tests for proper output value typing of the major
### categories of PDL primitive operations.
### For example:
### If $pdlderived is a PDL::derived object (subclassed from PDL),
### then $pdlderived->sumover should return a PDL::derived object.
###
# Test PDL Subclassing via hashes
########### Subclass typing Test ###########
## First define a PDL-derived object:
{
package PDL::Derived3;
our @ISA = qw/PDL::Hash/;
sub new {
my ($class, $data) = @_;
return $class->SUPER::new($data) if ref($data) ne 'PDL'; # if not object, inherited constructor
my $self = $class->initialize;
$self->{PDL} = $data;
$self;
}
####### Initialize function. This over-ridden function is called by the PDL constructors
sub initialize {
my ($class) = @_;
my $self = $class->SUPER::initialize;
# copy the other stuff:
$self->{someThingElse} = ref $class ? $class->{someThingElse} : 42;
$self;
}
}
## Now check to see if the different categories of primitive operations
## return the PDL::Derived3 type.
# Create a PDL::Derived3 instance
isa_ok $z = PDL::Derived3->new(ones(5,5)), "PDL::Derived3", "create derived instance";
#### Check the type after incrementing:
$z++;
isa_ok $z, "PDL::Derived3", "check type after incrementing";
#### Check the type after performing sumover:
isa_ok $z->sumover, "PDL::Derived3", "check type after sumover";
#### Check the type after adding two PDL::Derived3 objects:
my $x = PDL::Derived3->new( ones(5,5) ) ;
{
my @w;
local $SIG{__WARN__} = sub { push @w, @_ };
my $w = $x + $z;
isa_ok $w, "PDL::Derived3", "check type after adding";
is "@w", '', 'no warnings';
}
#### Check the type after calling null:
isa_ok +PDL::Derived3->null, "PDL::Derived3", "check type after calling null";
##### Check the type for a biops2 operation:
isa_ok +($x == $z), "PDL::Derived3", "check type for biops2 operation";
##### Check the type for a biops3 operation:
isa_ok +($x | $z), "PDL::Derived3", "check type for biops3 operation";
##### Check the type for a ufuncs1 operation:
isa_ok sqrt($z), "PDL::Derived3", "check type for ufuncs1 operation";
##### Check the type for a ufuncs1f operation:
isa_ok sin($z), "PDL::Derived3", "check type for ufuncs1f operation";
##### Check the type for a ufuncs2 operation:
isa_ok ! $z, "PDL::Derived3", "check type for ufuncs2 operation";
##### Check the type for a ufuncs2f operation:
isa_ok log $z, "PDL::Derived3", "check type for ufuncs2f operation";
##### Check the type for a bifuncs operation:
isa_ok $z**2, "PDL::Derived3", "check type for bifuncs operation";
##### Check the type for a slicing operation:
my $a1 = PDL::Derived3->new(1+(xvals zeroes 4,5) + 10*(yvals zeroes 4,5));
isa_ok $a1->slice('1:3:2,2:4:2'), "PDL::Derived3", "check type for slicing operation";
##### Check that slicing with a subclass index works (sf.net bug #369)
$a1 = sequence(10,3,2);
my $idx = PDL::Derived3->new(2,5,8);
ok(defined(eval 'my $r = $a1->slice($idx,"x","x");'), "slice works with subclass index");
########### Test of method over-riding in subclassed objects ###########
### Global Variable used to tell if method over-riding worked ###
$main::OVERRIDEWORKED = 0;
## First define a PDL-derived object:
{
package PDL::Derived4;
our @ISA = qw/PDL::Hash/;
sub new {
my ($class, $data) = @_;
return $class->SUPER::new($data) if ref($data) ne 'PDL'; # if not object, inherited constructor
my $self = $class->initialize;
$self->{PDL} = $data;
return $self;
}
####### Initialize function. This over-ridden function is called by the PDL constructors
sub initialize {
$::INIT_CALLED = 1;
my $class = shift;
my $self = $class->SUPER::initialize;
# copy the other stuff:
$self->{someThingElse} = ref $class ? $class->{someThingElse} : 42;
$self;
}
### Check of over-riding sumover
### This sumover should be called from PDL->sum.
### If the result is different from the normal sumover by $self->{SomethingElse} (42) then
### we will know that it has been called.
sub sumover {
my ($self, $out) = @_;
return $self->SUPER::sumover + $self->{someThingElse} if !defined $out; # no-argument form of calling
$self->SUPER::sumover($out); # if output arg given
$out += $self->{someThingElse};
}
# test of overriding methods. Calls inherited method and
# sets the Global variable main::OVERRIDEWORKED if called
for (qw(minmaximum inner which one2nd)) {
eval <<EOF;
sub $_ {
\$main::OVERRIDEWORKED = 1; # set global so we know over-ride worked.
my \$self = shift;
\$self->SUPER::$_(\@_);
}
EOF
}
}
###### Testing Begins #########
my $im = PDL::Derived4->new([
[ 1, 2, 3, 3 , 5],
[ 2, 3, 4, 5, 6],
[13, 13, 13, 13, 13],
[ 1, 3, 1, 3, 1],
[10, 10, 2, 2, 2,]
]);
isa_ok $im, 'PDL::Derived4';
isa_ok $im->flat, 'PDL::Derived4';
{
my @w;
local $SIG{__WARN__} = sub { push @w, @_ };
# Check overridden sumover called by sum: 134 if PDL::sumover called
is $im->sum, 176, "PDL::sumover is called by sum";
is "@w", '', 'no warnings';
}
### Test over-ride of minmaximum:
$main::OVERRIDEWORKED = 0;
my @minMax = $im->minmax;
is $main::OVERRIDEWORKED, 1, "over-ride of minmaximum";
### Test over-ride of inner:
## Update to use inner, not matrix mult - CED 8-May-2010
$main::OVERRIDEWORKED = 0;
my $matMultRes = $im->inner($im);
is $main::OVERRIDEWORKED, 1, "over-ride of inner";
### Test over-ride of which, one2nd
$main::OVERRIDEWORKED = 0;
# which ND test
$a1= PDL::Derived4->sequence(10,10,3,4);
($x, my $y, $z, my $w) = whichND($a1 == 203)->mv(0,-1)->dog;
is $main::OVERRIDEWORKED, 1, "whichND worked"; # whitebox test condition, uugh!
# Check to see if the clip functions return a derived object:
isa_ok $im->clip(5,7), "PDL::Derived4", "clip returns derived object";
isa_ok $im->hclip(5), "PDL::Derived4", "hclip returns derived object";
isa_ok $im->lclip(5), "PDL::Derived4", "lclip returns derived object";
$::INIT_CALLED = 0;
my $im2 = $im + 1;
ok $::INIT_CALLED, 'yes init';
$::INIT_CALLED = 0;
$im++;
ok !$::INIT_CALLED, 'no init';
######## Test of Subclassed-object copying for simple function cases ########
# Set 'someThingElse' Data Member to 24. (from 42)
$im->{someThingElse} = 24;
# Test to see if simple functions (a functions
# with signature sqrt a(), [o]b() ) copies subclassed object correctly.
foreach my $op (qw(bitnot sqrt abs sin cos not exp log10)) {
$w = $im->$op();
is $w->{someThingElse}, 24, "$op subclassed object correctly";
}
done_testing;