#!/usr/bin/perl
#
use PDL::LiteF;
use Test::More tests => 7;
########### 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::Derived;
@PDL::Derived::ISA = qw/PDL/;
sub new {
my $class = shift;
my $data = $_[0];
my $self;
if(ref($data) eq 'PDL' ){ # if $data is an object (a pdl)
$self = $class->initialize;
$self->{PDL} = $data;
}
else{ # if $data not an object call inherited constructor
$self = $class->SUPER::new($data);
}
return $self;
}
####### Initialize function. This over-ridden function is called by the PDL constructors
sub initialize {
my $class = shift;
my $self = {
PDL => PDL->null, # used to store PDL object
someThingElse => 42,
};
$class = (ref $class ? ref $class : $class );
bless $self, $class;
}
###### Derived Object Needs to supply its own copy #####
sub copy {
my $self = shift;
# setup the object
my $new = $self->initialize;
# copy the PDL
$new->{PDL} = $self->{PDL}->SUPER::copy;
# copy the other stuff:
$new->{someThingElse} = $self->{someThingElse};
return $new;
}
### 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 = shift;
my ($arg) = @_;
if( ! defined $arg){ # no-argument form of calling
$arg = $self->SUPER::sumover;
return $self->{someThingElse} + $arg;
}
else{ # one-argument form of calling
$self->SUPER::sumover($arg);
$arg += $self->{someThingElse};
}
}
#### test of overriding minmaximum. Calls inherited minmaximum and
#### Sets the Global variable main::OVERRIDEWORKED if called ####
sub minmaximum{
my $self = shift;
my ($arg) = @_;
$main::OVERRIDEWORKED = 1; # set the global variable so we know over-ride worked.
# print "In over-ridden minmaximum\n";
$self->SUPER::minmaximum(@_);
}
#### test of overriding inner. Calls inherited inner and
#### Sets the Global variable main::OVERRIDEWORKED if called ####
sub inner{
my $self = shift;
my ($arg) = @_;
$main::OVERRIDEWORKED = 1; # set the global variable so we know over-ride worked.
# print "In over-ridden inner\n";
$self->SUPER::inner(@_);
}
#### test of overriding which. Calls inherited which and
#### Sets the Global variable main::OVERRIDEWORKED if called ####
sub which{
my $self = shift;
my ($arg) = @_;
$main::OVERRIDEWORKED++; # set the global variable so we know over-ride worked.
# print "In over-ridden which\n";
$self->SUPER::which(@_);
}
#### test of overriding one2nd. Calls inherited one2nd and
#### increments the Global variable main::OVERRIDEWORKED if called ####
sub one2nd{
my $self = shift;
my ($arg) = @_;
$main::OVERRIDEWORKED++; # set the global variable so we know over-ride worked.
# print "In over-ridden one2nd\n";
$self->SUPER::one2nd(@_);
}
#######################################################
package main;
###### Testing Begins #########
$im = new PDL::Derived [
[ 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,]
];
# Check for PDL::sumover being called by sum
ok($im->sum == 176, "PDL::sumover is called by sum" ); # result will be = 134 if derived sumover
# is not called, 176 if it is called.
### Test over-ride of minmaximum:
$main::OVERRIDEWORKED = 0;
my @minMax = $im->minmax;
ok($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);
ok($main::OVERRIDEWORKED == 1, "over-ride of inner");
### Test over-ride of which, one2nd
$main::OVERRIDEWORKED = 0;
# which ND test
my $a= PDL::Derived->sequence(10,10,3,4);
# $PDL::whichND_no_warning = 1;
# my ($x, $y, $z, $w)=whichND($a == 203);
# ok($main::OVERRIDEWORKED == 2, "whichND test");
my ($x, $y, $z, $w) = whichND($a == 203)->mv(0,-1)->dog; # quiet deprecation warning
ok($main::OVERRIDEWORKED == 1, "whichND worked"); # whitebox test condition, uugh!
# Check to see if the clip functions return a derived object:
ok(ref( $im->clip(5,7) ) eq "PDL::Derived", "clip returns derived object");
ok(ref( $im->hclip(5) ) eq "PDL::Derived", "hclip returns derived object");
ok(ref( $im->lclip(5) ) eq "PDL::Derived", "lclip returns derived object");