1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
|
# Tests for self referential tree save and reload where most refs to the root are weakened.
use strict;
use warnings;
use File::Spec;
use Scalar::Util qw /weaken/;
local $|= 1;
use lib File::Spec->catdir(qw(t lib));
BEGIN {
lib->import('lib')
if !-d 't';
}
use Sereal::TestSet qw(:all);
use Sereal::BulkTest qw(:all);
use Test::More;
use Sereal::Encoder;
my $ok= have_encoder_and_decoder();
if ( not $ok ) {
plan skip_all => 'Did not find right version of decoder';
}
else {
run_weakref_tests();
}
sub run_weakref_tests {
# Child to parent refs are weak, root node is stored once in the hash
# Was failing on x64 Strawberry perls 5.16.3, 5.18.4, 5.20.1
test_save_and_reload();
# Child to parent refs are weak, but we store the root node twice in the hash
# (second time is in the "TREE_BY_NAME" subhash)
# Was failing on x64 Strawberry perls 5.16.3, passing on 5.18.4, 5.20.1
test_save_and_reload( store_root_by_name => 1 );
# child to parent refs are strong
# Should pass
test_save_and_reload( no_weaken_refs => 1 );
}
pass();
done_testing();
exit;
sub get_data {
my %args= @_;
my @children;
my $root= {
name => 'root',
children => \@children,
};
my %hash= (
TREE => $root,
TREE_BY_NAME => {},
);
if ( $args{store_root_by_name} ) {
$hash{TREE_BY_NAME}{root}= $root;
}
foreach my $i ( 0 .. 1 ) {
my $child= {
PARENT => $root,
NAME => $i,
};
if ( !$args{no_weaken_refs} ) {
weaken $child->{PARENT};
}
push @children, $child;
# store it in the by-name cache
$hash{TREE_BY_NAME}{$i}= $child;
}
return \%hash;
}
sub test_save_and_reload {
my %args= @_;
my $data= get_data(%args);
#diag '=== ARGS ARE: ' . join ' ', %args;
my $context_text;
$context_text .= $args{no_weaken} ? 'not weakened' : 'weakened';
$context_text .=
$args{store_root_by_name}
? ', extra root ref stored'
: ', extra root ref not stored';
my $encoder= Sereal::Encoder->new;
my $decoder= Sereal::Decoder->new;
my ( $encoded_data, $decoded_data );
$encoded_data= eval { $encoder->encode($data) };
my $e= $@;
ok( !$e, "Encoded without exception, $context_text" );
# no point testing if serialisation failed
if ($encoded_data) {
eval { $decoder->decode( $encoded_data, $decoded_data ) };
my $e= $@;
ok( !$e, "Decoded using Sereal, $context_text" );
is_deeply(
$decoded_data,
$data,
"Data structures match, $context_text",
);
}
}
1;
|
