{
our
@ISA
=
qw/PDL/
;
sub
new {
my
$class
=
shift
;
bless
{
PDL
=>
shift
,
SomethingElse
=>42},
$class
;
}
}
my
$z
= PDL::Derived->new( ones(5,5) ) ;
$z
++;
ok(sum(
$z
)==50,
"derived object does PDL stuff"
);
ok(
$$z
{SomethingElse}==42,
"derived has extra bits"
);
undef
$z
;
{
our
@ISA
=
qw/PDL/
;
sub
new {
my
$class
=
shift
;
bless
{
Coeff
=>
shift
,
PDL
=>\
&cache
,
SomethingElse
=>42},
$class
;
}
sub
cache {
my
$self
=
shift
;
return
$self
->{Cache}
if
exists
$self
->{Cache};
$self
->{Cache} = PDL->ones(
@$self
{
qw(Coeff Coeff)
})+2;
}
}
$z
= PDL::Derived2->new(5);
$z
++;
ok(sum(
$z
)==100,
"derived2 has PDL properties"
);
ok(
$$z
{SomethingElse}==42,
"derived2 has extra bits"
);
undef
$z
;
{
our
@ISA
=
qw/PDL::Hash/
;
sub
new {
my
(
$class
,
$data
) =
@_
;
return
$class
->SUPER::new(
$data
)
if
ref
(
$data
) ne
'PDL'
;
my
$self
=
$class
->initialize;
$self
->{PDL} =
$data
;
$self
;
}
sub
initialize {
my
(
$class
) =
@_
;
my
$self
=
$class
->SUPER::initialize;
$self
->{someThingElse} =
ref
$class
?
$class
->{someThingElse} : 42;
$self
;
}
}
isa_ok
$z
= PDL::Derived3->new(ones(5,5)),
"PDL::Derived3"
,
"create derived instance"
;
$z
++;
isa_ok
$z
,
"PDL::Derived3"
,
"check type after incrementing"
;
isa_ok
$z
->sumover,
"PDL::Derived3"
,
"check type after sumover"
;
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'
;
}
isa_ok +PDL::Derived3->null,
"PDL::Derived3"
,
"check type after calling null"
;
isa_ok +(
$x
==
$z
),
"PDL::Derived3"
,
"check type for biops2 operation"
;
isa_ok +(
$x
|
$z
),
"PDL::Derived3"
,
"check type for biops3 operation"
;
isa_ok
sqrt
(
$z
),
"PDL::Derived3"
,
"check type for ufuncs1 operation"
;
isa_ok
sin
(
$z
),
"PDL::Derived3"
,
"check type for ufuncs1f operation"
;
isa_ok !
$z
,
"PDL::Derived3"
,
"check type for ufuncs2 operation"
;
isa_ok
log
$z
,
"PDL::Derived3"
,
"check type for ufuncs2f operation"
;
isa_ok
$z
**2,
"PDL::Derived3"
,
"check type for bifuncs 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"
;
$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"
);
$main::OVERRIDEWORKED
= 0;
{
our
@ISA
=
qw/PDL::Hash/
;
sub
new {
my
(
$class
,
$data
) =
@_
;
return
$class
->SUPER::new(
$data
)
if
ref
(
$data
) ne
'PDL'
;
my
$self
=
$class
->initialize;
$self
->{PDL} =
$data
;
return
$self
;
}
sub
initialize {
$::INIT_CALLED = 1;
my
$class
=
shift
;
my
$self
=
$class
->SUPER::initialize;
$self
->{someThingElse} =
ref
$class
?
$class
->{someThingElse} : 42;
$self
;
}
sub
sumover {
my
(
$self
,
$out
) =
@_
;
return
$self
->SUPER::sumover +
$self
->{someThingElse}
if
!
defined
$out
;
$self
->SUPER::sumover(
$out
);
$out
+=
$self
->{someThingElse};
}
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
}
}
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
,
@_
};
is
$im
->sum, 176,
"PDL::sumover is called by sum"
;
is
"@w"
,
''
,
'no warnings'
;
}
$main::OVERRIDEWORKED
= 0;
my
@minMax
=
$im
->minmax;
is
$main::OVERRIDEWORKED
, 1,
"over-ride of minmaximum"
;
$main::OVERRIDEWORKED
= 0;
my
$matMultRes
=
$im
->inner(
$im
);
is
$main::OVERRIDEWORKED
, 1,
"over-ride of inner"
;
$main::OVERRIDEWORKED
= 0;
$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"
;
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'
;
$im
->{someThingElse} = 24;
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;