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
|
#!/usr/bin/perl -T -w
BEGIN {
if( $ENV{PERL_CORE} ) {
chdir 't';
@INC = '../lib';
}
}
BEGIN {
unless ( eval { require Storable; 1 } ){
print "1..0 # Skip -- Storable is not available\n";
exit 0;
}
}
use strict;
use Tie::RefHash;
use Storable qw/dclone nfreeze thaw/;
$\ = "\n";
print "1..42";
sub ok ($$) {
print ( ( $_[0] ? "" : "not " ), "ok - $_[1]" );
}
sub is ($$$) {
print ( ( ( $_[0] eq $_[1] ) ? "" : "not "), "ok - $_[2]" );
}
sub isa_ok ($$) {
ok( eval { $_[0]->isa($_[1]) }, "the object isa $_[1]");
}
tie my %hash, "Tie::RefHash";
my $key = { foo => 1 };
$hash{$key} = "value";
$hash{non_ref} = "other";
foreach my $clone ( \%hash, dclone(\%hash), thaw(nfreeze(\%hash)) ){
ok( tied(%$clone), "copy is tied");
isa_ok( tied(%$clone), "Tie::RefHash" );
my @keys = keys %$clone;
is( scalar(@keys), 2, "two keys in clone");
my $key = ref($keys[0]) ? shift @keys : pop @keys;
my $reg = $keys[0];
ok( ref($key), "key is a ref after clone" );
is( $key->{foo}, 1, "key serialized ok");
is( $clone->{$key}, "value", "and is still pointing at the same value" );
ok( !ref($reg), "regular key is non ref" );
is( $clone->{$reg}, "other", "and is also a valid key" );
}
tie my %only_refs, "Tie::RefHash";
$only_refs{$key} = "value";
foreach my $clone ( \%only_refs, dclone(\%only_refs), thaw(nfreeze(\%only_refs)) ){
ok( tied(%$clone), "copy is tied");
isa_ok( tied(%$clone), "Tie::RefHash" );
my @keys = keys %$clone;
is( scalar(@keys), 1, "one key in clone");
my $key = $keys[0];
ok( ref($key), "key is a ref after clone" );
is( $key->{foo}, 1, "key serialized ok");
is( $clone->{$key}, "value", "and is still pointing at the same value" );
}
|
