1#!/usr/local/bin/perl
2#
3use PDL::LiteF;
4use Test::More tests => 7;
5
6
7########### Test of method over-riding in subclassed objects ###########
8
9### Global Variable used to tell if method over-riding worked ###
10$main::OVERRIDEWORKED = 0;
11
12
13##  First define a PDL-derived object:
14package PDL::Derived;
15
16@PDL::Derived::ISA = qw/PDL/;
17
18
19sub new {
20   my $class = shift;
21
22   my $data = $_[0];
23
24   my $self;
25   if(ref($data) eq 'PDL' ){ # if $data is an object (a pdl)
26	   $self = $class->initialize;
27	   $self->{PDL} = $data;
28   }
29   else{	# if $data not an object call inherited constructor
30	   $self = $class->SUPER::new($data);
31   }
32
33
34   return $self;
35}
36
37####### Initialize function. This over-ridden function is called by the PDL constructors
38sub initialize {
39	my $class = shift;
40        my $self = {
41                PDL => PDL->null, 	# used to store PDL object
42		someThingElse => 42,
43        };
44	$class = (ref $class ? ref $class : $class );
45        bless $self, $class;
46}
47
48###### Derived Object Needs to supply its own copy #####
49sub copy {
50	my $self = shift;
51
52	# setup the object
53	my $new = $self->initialize;
54
55	# copy the PDL
56	$new->{PDL} = $self->{PDL}->SUPER::copy;
57
58	# copy the other stuff:
59	$new->{someThingElse} = $self->{someThingElse};
60
61	return $new;
62
63}
64
65### Check of over-riding sumover
66### This sumover should be called from PDL->sum.
67###  If the result is different from the normal sumover by $self->{SomethingElse} (42) then
68###   we will know that it has been called.
69sub sumover{
70	my $self = shift;
71	my ($arg) = @_;
72	if( ! defined $arg){   # no-argument form of calling
73		$arg = $self->SUPER::sumover;
74		return $self->{someThingElse} + $arg;
75	}
76	else{  # one-argument form of calling
77		$self->SUPER::sumover($arg);
78		$arg +=  $self->{someThingElse};
79	}
80
81
82}
83
84#### test of overriding minmaximum. Calls inherited minmaximum and
85####  Sets the Global variable main::OVERRIDEWORKED if called ####
86sub minmaximum{
87	my $self = shift;
88	my ($arg) = @_;
89	$main::OVERRIDEWORKED = 1;  # set the global variable so we know over-ride worked.
90	# print "In over-ridden minmaximum\n";
91	$self->SUPER::minmaximum(@_);
92}
93
94#### test of overriding inner. Calls inherited inner and
95####  Sets the Global variable main::OVERRIDEWORKED if called ####
96sub inner{
97	my $self = shift;
98	my ($arg) = @_;
99	$main::OVERRIDEWORKED = 1;  # set the global variable so we know over-ride worked.
100	# print "In over-ridden inner\n";
101	$self->SUPER::inner(@_);
102}
103
104#### test of overriding which. Calls inherited which and
105####  Sets the Global variable main::OVERRIDEWORKED if called ####
106sub which{
107	my $self = shift;
108	my ($arg) = @_;
109	$main::OVERRIDEWORKED++;  # set the global variable so we know over-ride worked.
110	# print "In over-ridden which\n";
111	$self->SUPER::which(@_);
112}
113
114#### test of overriding one2nd. Calls inherited one2nd and
115####  increments the Global variable main::OVERRIDEWORKED if called ####
116sub one2nd{
117	my $self = shift;
118	my ($arg) = @_;
119	$main::OVERRIDEWORKED++;  # set the global variable so we know over-ride worked.
120	# print "In over-ridden one2nd\n";
121	$self->SUPER::one2nd(@_);
122}
123#######################################################
124package main;
125
126###### Testing Begins #########
127
128$im = new PDL::Derived [
129  [ 1, 2,  3,  3 , 5],
130  [ 2,  3,  4,  5,  6],
131  [13, 13, 13, 13, 13],
132  [ 1,  3,  1,  3,  1],
133  [10, 10,  2,  2,  2,]
134 ];
135
136
137# Check for PDL::sumover being called by sum
138ok($im->sum == 176, "PDL::sumover is called by sum" ); # result will be = 134 if derived sumover
139                                                       # is not called,   176 if it is called.
140
141### Test over-ride of minmaximum:
142$main::OVERRIDEWORKED = 0;
143my @minMax = $im->minmax;
144ok($main::OVERRIDEWORKED == 1, "over-ride of minmaximum");
145
146
147### Test over-ride of inner:
148## Update to use inner, not matrix mult - CED 8-May-2010
149$main::OVERRIDEWORKED = 0;
150my $matMultRes = $im->inner($im);
151ok($main::OVERRIDEWORKED == 1, "over-ride of inner");
152
153### Test over-ride of which, one2nd
154$main::OVERRIDEWORKED = 0;
155# which ND test
156my $a= PDL::Derived->sequence(10,10,3,4);
157# $PDL::whichND_no_warning = 1;
158# my ($x, $y, $z, $w)=whichND($a == 203);
159# ok($main::OVERRIDEWORKED == 2, "whichND test");
160my ($x, $y, $z, $w) = whichND($a == 203)->mv(0,-1)->dog;  # quiet deprecation warning
161ok($main::OVERRIDEWORKED == 1, "whichND worked");         # whitebox test condition, uugh!
162
163# Check to see if the clip functions return a derived object:
164ok(ref( $im->clip(5,7) ) eq "PDL::Derived", "clip returns derived object");
165ok(ref( $im->hclip(5) ) eq "PDL::Derived", "hclip returns derived object");
166ok(ref( $im->lclip(5) ) eq "PDL::Derived", "lclip returns derived object");
167