# -*- cperl -*-
use strict;
use Test::More;
BEGIN {
eval 'use Storable 1.03';
unless ($@) {
plan tests => 23;
} else {
plan skip_all => "Storable >= 1.03 not installed\n";
}
use Storable qw/freeze thaw retrieve/;
}
BEGIN {
use PDL::LiteF;
use PDL::Dbg;
use_ok('PDL::IO::Storable');
}
my ($data,$dfreeze,$dthaw,$olda,$pfreeze,$phash,$phthaw,$seq1,$seq1_tf,$seq2,$seq2_dc,$serialized);
$a = sequence(2,2);
# $a->dump;
$serialized = freeze $a;
$olda = thaw $serialized;
# $olda->dump;
ok(sum(abs($a-$olda))==0, 'PDL freeze/thaw');
# $oldb = thaw $serialized;
# $oldc = thaw $serialized;
#
# $PDL::Dbg::Infostr = "%T %D %S %A";
# PDL->px;
#
# undef $oldb;
# print $oldc;
undef $a;
$data = {
key1 => 1,
key2 => sequence(3),
key3 => 'hallo',
};
$dfreeze = freeze $data;
$dthaw = thaw $dfreeze;
isa_ok($dthaw, 'HASH'); # we got a HASH back
ok(all($data->{key2} == $dthaw->{key2}), 'PDL in structure');
$phash = bless {PDL => sequence 3}, 'PDL';
can_ok($phash, 'freeze');
$pfreeze = $phash->freeze;
$phthaw = thaw $pfreeze;
ok(all($phthaw == $phash), 'PDL has-a works with freeze/thaw');
ok(UNIVERSAL::isa($phthaw,'HASH'), 'PDL is a hash');
# Test that freeze + thaw results in new object
$seq1 = sequence(3);
$seq1_tf = thaw(freeze($seq1));
$seq1->slice('1') .= 9;
ok(! all($seq1 == $seq1_tf), 'Initialization from seraialized object') or
diag($seq1, $seq1_tf);
# Test that dclone results in a new object
# i.e. that dclone(.) == thaw(freeze(.))
$seq2 = sequence(4);
$seq2_dc = Storable::dclone($seq2);
$seq2->slice('2') .= 8;
ok(! all($seq2 == $seq2_dc), 'Initialization from dclone object') or
diag($seq2, $seq2_dc);
# Now test reading from files
testLoad($_) foreach( qw(t/storable_new_amd64.dat t/storable_old_amd64.dat) );
# tests loading some files made on different architectures. All these files were
# made with this:
#
# use PDL;
# use PDL::IO::Storable;
# use Storable qw(nstore);
# my $x = sequence(3,3)->byte * sequence(3)->byte;
# my $y = 50 + sequence(7)->double;
# nstore [$x, 'abcd', $y], "/tmp/tst.dat";
#
# I make sure these all were read correctly
sub testLoad
{
my $filename = shift;
# if we're on a big endian machine, the old-style data will be bogus so I skip
# the tests in that case
SKIP:
{
if ( $filename =~ /_old_/ )
{
my ($byte0) = unpack( 'C*', pack( 'l', 1 ));
if ( $byte0 == 0 )
{
skip "On a big endian machine the old stored files will be bogus", 7;
}
}
my $x = retrieve $filename;
ok( defined $x, "Reading from file '$filename'" );
ok( @$x == 3, "Reading an array-ref of size 3 from file '$filename'" );
ok( $x->[1] eq 'abcd', "Reading a correct string from file '$filename'" );
isa_ok( $x->[0], 'PDL', "Reading a piddle from file '$filename'" );
isa_ok( $x->[2], 'PDL', "Reading another piddle from file '$filename'" );
my $diff0 = $x->[0] - pdl[[0,1,4],
[0,4,10],
[0,7,16]];
my $diff2 = $x->[2] - (50 + sequence(7));
ok( $diff0->max == 0, "Read correct data from file '$filename'" );
ok( $diff2->max == 0, "Read more correct data from file '$filename'" );
}
}