1#!/usr/bin/perl -T -w
2
3BEGIN {
4    if( $ENV{PERL_CORE} ) {
5        chdir 't';
6        @INC = '../lib';
7    }
8}
9
10BEGIN {
11  unless ( eval { require Storable; 1 } ){
12    print "1..0 # Skip -- Storable is not available\n";
13    exit 0;
14  }
15}
16
17use strict;
18
19use Tie::RefHash;
20
21use Storable qw/dclone nfreeze thaw/;
22
23$\ = "\n";
24print "1..42";
25
26sub ok ($$) {
27    print ( ( $_[0] ? "" : "not " ), "ok - $_[1]" );
28}
29
30sub is ($$$) {
31    print ( ( ( $_[0] eq $_[1] ) ? "" : "not "), "ok - $_[2]" );
32}
33
34sub isa_ok ($$) {
35    ok( eval { $_[0]->isa($_[1]) }, "the object isa $_[1]");
36}
37
38tie my %hash, "Tie::RefHash";
39
40my $key = { foo => 1 };
41$hash{$key} = "value";
42$hash{non_ref} = "other";
43
44foreach my $clone ( \%hash, dclone(\%hash), thaw(nfreeze(\%hash)) ){
45
46  ok( tied(%$clone), "copy is tied");
47  isa_ok( tied(%$clone), "Tie::RefHash" );
48
49  my @keys = keys %$clone;
50  is( scalar(@keys), 2, "two keys in clone");
51  my $key = ref($keys[0]) ? shift @keys : pop @keys;
52  my $reg = $keys[0];
53
54  ok( ref($key), "key is a ref after clone" );
55  is( $key->{foo}, 1, "key serialized ok");
56
57  is( $clone->{$key}, "value", "and is still pointing at the same value" );
58
59  ok( !ref($reg), "regular key is non ref" );
60  is( $clone->{$reg}, "other", "and is also a valid key" );
61}
62
63tie my %only_refs, "Tie::RefHash";
64$only_refs{$key} = "value";
65
66foreach my $clone ( \%only_refs, dclone(\%only_refs), thaw(nfreeze(\%only_refs)) ){
67
68  ok( tied(%$clone), "copy is tied");
69  isa_ok( tied(%$clone), "Tie::RefHash" );
70
71  my @keys = keys %$clone;
72  is( scalar(@keys), 1, "one key in clone");
73  my $key = $keys[0];
74
75  ok( ref($key), "key is a ref after clone" );
76  is( $key->{foo}, 1, "key serialized ok");
77
78  is( $clone->{$key}, "value", "and is still pointing at the same value" );
79}
80
81