"Fossies" - the Fresh Open Source Software Archive  

Source code changes of the file "t/subclass.t" between
PDL-2.082.tar.gz and PDL-2.083.tar.gz

About: PDL (Perl Data Language) aims to turn perl into an efficient numerical language for scientific computing (similar to IDL and MatLab).

[ To the main PDL source changes report ]

subclass.t  (PDL-2.082):subclass.t  (PDL-2.083)
skipping to change at line 126 skipping to change at line 126
# copy the other stuff: # copy the other stuff:
$new->{someThingElse} = $self->{someThingElse}; $new->{someThingElse} = $self->{someThingElse};
return $new; return $new;
} }
} }
## Now check to see if the different categories of primitive operations ## Now check to see if the different categories of primitive operations
## return the PDL::Derived3 type. ## return the PDL::Derived3 type.
# Create a PDL::Derived3 instance # Create a PDL::Derived3 instance
$z = PDL::Derived3->new( ones(5,5) ) ; $z = PDL::Derived3->new( ones(5,5) ) ;
ok(ref($z)eq"PDL::Derived3", "create derived instance"); is ref($z), "PDL::Derived3", "create derived instance";
#### Check the type after incrementing: #### Check the type after incrementing:
$z++; $z++;
ok(ref($z) eq "PDL::Derived3", "check type after incrementing"); is ref($z), "PDL::Derived3", "check type after incrementing";
#### Check the type after performing sumover: #### Check the type after performing sumover:
my $y = $z->sumover; my $y = $z->sumover;
ok(ref($y) eq "PDL::Derived3", "check type after sumover"); is ref($y), "PDL::Derived3", "check type after sumover";
#### Check the type after adding two PDL::Derived3 objects: #### Check the type after adding two PDL::Derived3 objects:
my $x = PDL::Derived3->new( ones(5,5) ) ; my $x = PDL::Derived3->new( ones(5,5) ) ;
my $w = $x + $z; {
ok(ref($w) eq "PDL::Derived3", "check type after adding"); my @w;
local $SIG{__WARN__} = sub { push @w, @_ };
my $w = $x + $z;
is ref($w), "PDL::Derived3", "check type after adding";
is "@w", '', 'no warnings';
}
#### Check the type after calling null: #### Check the type after calling null:
my $a1 = PDL::Derived3->null(); my $a1 = PDL::Derived3->null();
ok(ref($a1) eq "PDL::Derived3", "check type after calling null"); is ref($a1), "PDL::Derived3", "check type after calling null";
##### Check the type for a biops2 operation: ##### Check the type for a biops2 operation:
$w = ($x == $z); my $w = ($x == $z);
ok(ref($w) eq "PDL::Derived3", "check type for biops2 operation"); is ref($w), "PDL::Derived3", "check type for biops2 operation";
##### Check the type for a biops3 operation: ##### Check the type for a biops3 operation:
$w = ($x | $z); $w = ($x | $z);
ok(ref($w) eq "PDL::Derived3", "check type for biops3 operation"); is ref($w), "PDL::Derived3", "check type for biops3 operation";
##### Check the type for a ufuncs1 operation: ##### Check the type for a ufuncs1 operation:
$w = sqrt($z); $w = sqrt($z);
ok(ref($w) eq "PDL::Derived3", "check type for ufuncs1 operation"); is ref($w), "PDL::Derived3", "check type for ufuncs1 operation";
##### Check the type for a ufuncs1f operation: ##### Check the type for a ufuncs1f operation:
$w = sin($z); $w = sin($z);
ok(ref($w) eq "PDL::Derived3", "check type for ufuncs1f operation"); is ref($w), "PDL::Derived3", "check type for ufuncs1f operation";
##### Check the type for a ufuncs2 operation: ##### Check the type for a ufuncs2 operation:
$w = ! $z; $w = ! $z;
ok(ref($w) eq "PDL::Derived3", "check type for ufuncs2 operation"); is ref($w), "PDL::Derived3", "check type for ufuncs2 operation";
##### Check the type for a ufuncs2f operation: ##### Check the type for a ufuncs2f operation:
$w = log $z; $w = log $z;
ok(ref($w) eq "PDL::Derived3", "check type for ufuncs2f operation"); is ref($w), "PDL::Derived3", "check type for ufuncs2f operation";
##### Check the type for a bifuncs operation: ##### Check the type for a bifuncs operation:
$w = $z**2; $w = $z**2;
ok(ref($w) eq "PDL::Derived3", "check type for bifuncs operation"); is ref($w), "PDL::Derived3", "check type for bifuncs operation";
##### Check the type for a slicing operation: ##### Check the type for a slicing operation:
$a1 = PDL::Derived3->new(1+(xvals zeroes 4,5) + 10*(yvals zeroes 4,5)); $a1 = PDL::Derived3->new(1+(xvals zeroes 4,5) + 10*(yvals zeroes 4,5));
$w = $a1->slice('1:3:2,2:4:2'); $w = $a1->slice('1:3:2,2:4:2');
ok(ref($w) eq "PDL::Derived3", "check type for slicing operation"); is ref($w), "PDL::Derived3", "check type for slicing operation";
##### Check that slicing with a subclass index works (sf.net bug #369) ##### Check that slicing with a subclass index works (sf.net bug #369)
$a1 = sequence(10,3,2); $a1 = sequence(10,3,2);
my $idx = PDL::Derived3->new(2,5,8); my $idx = PDL::Derived3->new(2,5,8);
ok(defined(eval 'my $r = $a1->slice($idx,"x","x");'), "slice works with subclass index"); ok(defined(eval 'my $r = $a1->slice($idx,"x","x");'), "slice works with subclass index");
########### Test of method over-riding in subclassed objects ########### ########### Test of method over-riding in subclassed objects ###########
### Global Variable used to tell if method over-riding worked ### ### Global Variable used to tell if method over-riding worked ###
$main::OVERRIDEWORKED = 0; $main::OVERRIDEWORKED = 0;
## First define a PDL-derived object: ## First define a PDL-derived object:
{ {
package PDL::Derived4; package PDL::Derived4;
our @ISA = qw/PDL/; our @ISA = qw/PDL/;
sub new { sub new {
my $class = shift; my $class = shift;
my $data = $_[0]; my $data = $_[0];
my $self; return $class->SUPER::new($data) if ref($data) ne 'PDL'; # if not object, inh
if(ref($data) eq 'PDL' ){ # if $data is an object (a pdl) erited constructor
$self = $class->initialize; my $self = $class->initialize;
$self->{PDL} = $data; $self->{PDL} = $data;
}
else{ # if $data not an object call inherited constructor
$self = $class->SUPER::new($data);
}
return $self; return $self;
} }
####### Initialize function. This over-ridden function is called by the PDL cons tructors ####### Initialize function. This over-ridden function is called by the PDL cons tructors
sub initialize { sub initialize {
$::INIT_CALLED = 1;
my $class = shift; my $class = shift;
my $self = { my $self = {
PDL => PDL->null, # used to store PDL object PDL => PDL->null, # used to store PDL object
someThingElse => 42, someThingElse => 42,
}; };
$class = (ref $class ? ref $class : $class ); $class = (ref $class ? ref $class : $class );
bless $self, $class; bless $self, $class;
} }
###### Derived4 Object Needs to supply its own copy ##### ###### Derived4 Object Needs to supply its own copy #####
sub copy { sub copy {
$::COPY_CALLED = 1;
my $self = shift; my $self = shift;
# setup the object # setup the object
my $new = $self->initialize; my $new = $self->initialize;
# copy the PDL # copy the PDL
$new->{PDL} = $self->{PDL}->SUPER::copy; $new->{PDL} = $self->{PDL}->SUPER::copy;
# copy the other stuff: # copy the other stuff:
$new->{someThingElse} = $self->{someThingElse}; $new->{someThingElse} = $self->{someThingElse};
return $new; return $new;
} }
skipping to change at line 248 skipping to change at line 250
else{ # one-argument form of calling else{ # one-argument form of calling
$self->SUPER::sumover($arg); $self->SUPER::sumover($arg);
$arg += $self->{someThingElse}; $arg += $self->{someThingElse};
} }
} }
#### test of overriding minmaximum. Calls inherited minmaximum and #### test of overriding minmaximum. Calls inherited minmaximum and
#### Sets the Global variable main::OVERRIDEWORKED if called #### #### Sets the Global variable main::OVERRIDEWORKED if called ####
sub minmaximum{ sub minmaximum{
my $self = shift; my $self = shift;
my ($arg) = @_;
$main::OVERRIDEWORKED = 1; # set the global variable so we know over-rid e worked. $main::OVERRIDEWORKED = 1; # set the global variable so we know over-rid e worked.
# print "In over-ridden minmaximum\n"; # print "In over-ridden minmaximum\n";
$self->SUPER::minmaximum(@_); $self->SUPER::minmaximum(@_);
} }
#### test of overriding inner. Calls inherited inner and #### test of overriding inner. Calls inherited inner and
#### Sets the Global variable main::OVERRIDEWORKED if called #### #### Sets the Global variable main::OVERRIDEWORKED if called ####
sub inner{ sub inner{
my $self = shift; my $self = shift;
my ($arg) = @_;
$main::OVERRIDEWORKED = 1; # set the global variable so we know over-rid e worked. $main::OVERRIDEWORKED = 1; # set the global variable so we know over-rid e worked.
# print "In over-ridden inner\n"; # print "In over-ridden inner\n";
$self->SUPER::inner(@_); $self->SUPER::inner(@_);
} }
#### test of overriding which. Calls inherited which and #### test of overriding which. Calls inherited which and
#### Sets the Global variable main::OVERRIDEWORKED if called #### #### Sets the Global variable main::OVERRIDEWORKED if called ####
sub which{ sub which{
my $self = shift; my $self = shift;
my ($arg) = @_;
$main::OVERRIDEWORKED++; # set the global variable so we know over-ride worked. $main::OVERRIDEWORKED++; # set the global variable so we know over-ride worked.
# print "In over-ridden which\n"; # print "In over-ridden which\n";
$self->SUPER::which(@_); $self->SUPER::which(@_);
} }
#### test of overriding one2nd. Calls inherited one2nd and #### test of overriding one2nd. Calls inherited one2nd and
#### increments the Global variable main::OVERRIDEWORKED if called #### #### increments the Global variable main::OVERRIDEWORKED if called ####
sub one2nd{ sub one2nd{
my $self = shift; my $self = shift;
my ($arg) = @_;
$main::OVERRIDEWORKED++; # set the global variable so we know over-ride worked. $main::OVERRIDEWORKED++; # set the global variable so we know over-ride worked.
# print "In over-ridden one2nd\n"; # print "In over-ridden one2nd\n";
$self->SUPER::one2nd(@_); $self->SUPER::one2nd(@_);
} }
} }
###### Testing Begins ######### ###### Testing Begins #########
my $im = PDL::Derived4->new([ my $im = PDL::Derived4->new([
[ 1, 2, 3, 3 , 5], [ 1, 2, 3, 3 , 5],
[ 2, 3, 4, 5, 6], [ 2, 3, 4, 5, 6],
[13, 13, 13, 13, 13], [13, 13, 13, 13, 13],
[ 1, 3, 1, 3, 1], [ 1, 3, 1, 3, 1],
[10, 10, 2, 2, 2,] [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 my @w;
derived sumover local $SIG{__WARN__} = sub { push @w, @_ };
# is not called, 176 if # Check for PDL::sumover being called by sum
it is called. is $im->sum, 176, "PDL::sumover is called by sum"; # result will be = 134 if d
erived sumover
# is not called, 176
if it is called.
is "@w", '', 'no warnings';
}
### Test over-ride of minmaximum: ### Test over-ride of minmaximum:
$main::OVERRIDEWORKED = 0; $main::OVERRIDEWORKED = 0;
my @minMax = $im->minmax; my @minMax = $im->minmax;
ok($main::OVERRIDEWORKED == 1, "over-ride of minmaximum"); is $main::OVERRIDEWORKED, 1, "over-ride of minmaximum";
### Test over-ride of inner: ### Test over-ride of inner:
## Update to use inner, not matrix mult - CED 8-May-2010 ## Update to use inner, not matrix mult - CED 8-May-2010
$main::OVERRIDEWORKED = 0; $main::OVERRIDEWORKED = 0;
my $matMultRes = $im->inner($im); my $matMultRes = $im->inner($im);
ok($main::OVERRIDEWORKED == 1, "over-ride of inner"); is $main::OVERRIDEWORKED, 1, "over-ride of inner";
### Test over-ride of which, one2nd ### Test over-ride of which, one2nd
$main::OVERRIDEWORKED = 0; $main::OVERRIDEWORKED = 0;
# which ND test # which ND test
$a1= PDL::Derived4->sequence(10,10,3,4); $a1= PDL::Derived4->sequence(10,10,3,4);
($x, $y, $z, $w) = whichND($a1 == 203)->mv(0,-1)->dog; ($x, $y, $z, $w) = whichND($a1 == 203)->mv(0,-1)->dog;
ok($main::OVERRIDEWORKED == 1, "whichND worked"); # whitebox test condition, uug h! is $main::OVERRIDEWORKED, 1, "whichND worked"; # whitebox test condition, uugh!
# Check to see if the clip functions return a derived object: # Check to see if the clip functions return a derived object:
ok(ref( $im->clip(5,7) ) eq "PDL::Derived4", "clip returns derived object"); is ref( $im->clip(5,7) ), "PDL::Derived4", "clip returns derived object";
ok(ref( $im->hclip(5) ) eq "PDL::Derived4", "hclip returns derived object"); is ref( $im->hclip(5) ), "PDL::Derived4", "hclip returns derived object";
ok(ref( $im->lclip(5) ) eq "PDL::Derived4", "lclip returns derived object"); is ref( $im->lclip(5) ), "PDL::Derived4", "lclip returns derived object";
$::COPY_CALLED = $::INIT_CALLED = 0;
my $im2 = $im + 1;
ok !$::COPY_CALLED, 'no copy';
ok $::INIT_CALLED, 'yes init';
$::COPY_CALLED = $::INIT_CALLED = 0;
$im++;
ok !$::COPY_CALLED, 'no copy';
ok !$::INIT_CALLED, 'no init';
########### Test of Subclassed-object copying for simple function cases ######## ### ########### Test of Subclassed-object copying for simple function cases ######## ###
## First define a PDL-derived object: ## First define a PDL-derived object:
{ {
package PDL::Derived5; package PDL::Derived5;
our @ISA = qw/PDL/; our @ISA = qw/PDL/;
sub new { sub new {
my $class = shift; my $class = shift;
my $data = $_[0]; my $data = $_[0];
skipping to change at line 388 skipping to change at line 401
# Set 'someThingElse' Data Member to 24. (from 42) # Set 'someThingElse' Data Member to 24. (from 42)
$im->{someThingElse} = 24; $im->{someThingElse} = 24;
# Test to see if simple functions (a functions # Test to see if simple functions (a functions
# with signature sqrt a(), [o]b() ) copies subclassed object correctly. # with signature sqrt a(), [o]b() ) copies subclassed object correctly.
my @simpleFuncs = (qw/bitnot sqrt abs sin cos not exp log10/); my @simpleFuncs = (qw/bitnot sqrt abs sin cos not exp log10/);
foreach my $op( @simpleFuncs){ foreach my $op( @simpleFuncs){
$w = $im->$op(); $w = $im->$op();
ok($w->{someThingElse} == 24, "$op subclassed object correctly"); is $w->{someThingElse}, 24, "$op subclassed object correctly";
} }
done_testing; done_testing;
 End of changes. 26 change blocks. 
39 lines changed or deleted 53 lines changed or added
To the Perl Test Programs section of the PDL source changes report or the top of this page
Mainly generated by pkgdiff using rfcdiff
Home  |  About  |  Features  |  All  |  Newest  |  Dox  |  Diffs  |  RSS Feeds  |  Screenshots  |  Comments  |  Imprint  |  Privacy  |  HTTP(S)