sub
inpath {
my
(
$prog
) =
@_
;
for
(
split
$Config
{path_sep},
$ENV
{PATH} ) {
return
1
if
-x
"$_/$prog$Config{exe_ext}"
}
return
;
}
BEGIN {
eval
"use Convert::UU;"
;
my
$hasuuencode
= !$@ || (inpath(
'uuencode'
) && inpath(
'uudecode'
));
if
(
$hasuuencode
) {
plan
tests
=> 16;
}
else
{
plan
skip_all
=>
"Skip neither uuencode/decode nor Convert:UU is available\n"
;
}
}
use_ok(
'PDL::IO::Dumper'
);
my
(
$s
,
$a
);
eval
'$s = sdump({a=>3,b=>pdl(4),c=>xvals(3,3),d=>xvals(4,4)});'
;
ok(!$@,
'Call sdump()'
)
or diag(
"Call sdump() output string:\n$s\n"
);
$a
=
eval
$s
;
ok(!$@,
'Can eval dumped data code'
) or diag(
"The output string was '$s'\n"
);
ok(
ref
$a
eq
'HASH'
,
'HASH was restored'
);
ok((
$a
->{a}==3),
'SCALAR value restored ok'
);
ok(((
ref
$a
->{b} eq
'PDL'
) && (
$a
->{b}==4)),
'0-d PDL restored ok'
);
ok(((
ref
$a
->{c} eq
'PDL'
) && (
$a
->{c}->nelem == 9)
&& (sum(
abs
((
$a
->{c} - xvals(3,3))))<0.0000001)),
'3x3 PDL restored ok'
);
ok(((
ref
$a
->{d} eq
'PDL'
) && (
$a
->{d}->nelem == 16)
&& (sum(
abs
((
$a
->{d} - xvals(4,4))))<0.0000001)),
'4x4 PDL restored ok'
);
eval
'$s = sdump({e=>xvals(25,25)});'
;
ok(!$@,
'sdump() of 25x25 PDL to test uuencode dumps'
);
$a
=
eval
$s
;
ok(!$@,
'Can eval dumped 25x25 PDL'
);
if
( $@ ) {
diag
"--- ERROR ---\n"
;
diag
"--Error message start:\n"
;
diag $@;
diag
"\n--Error message end:\n"
;
diag
"String was:\n$s\n"
;
diag
"--- ERROR (end) ---\n"
;
}
ok((
ref
$a
eq
'HASH'
),
'HASH structure for uuencoded 25x25 PDL restored'
);
ok(((
ref
$a
->{e} eq
'PDL'
)
&& (
$a
->{e}->nelem==625)
&& (sum(
abs
((
$a
->{e} - xvals(25,25))))<0.0000001)),
'Verify 25x25 PDL restored data'
);
eval
'$a = xvals(2,2); $a->sethdr({ok=>1}); $a->hdrcpy(1); $b = xvals(25,25); $b->sethdr({ok=>2}); $b->hdrcpy(0); $s = sdump([$a,$b,yvals(25,25)]);'
;
ok(!$@,
'Check header dumping'
);
$a
=
eval
$s
;
ok((!$@ && (
ref
$a
eq
'ARRAY'
)),
'ARRAY can restore'
);
ok(
eval
(
'$a->[0]->hdrcpy() == 1 && $a->[1]->hdrcpy() == 0'
),
'Check hdrcpy()\'s persist'
);
ok(
eval
(
'($a->[0]->gethdr()->{ok}==1) && ($a->[1]->gethdr()->{ok}==2)'
),
'Check gethdr() values persist'
);