9 Tie::RefHash - use references as hash keys
15 tie HASHVARIABLE, 'Tie::RefHash', LIST;
16 tie HASHVARIABLE, 'Tie::RefHash::Nestable', LIST;
22 This module provides the ability to use references as hash keys if you
23 first C<tie> the hash variable to this module. Normally, only the
24 keys of the tied hash itself are preserved as references; to use
25 references as keys in hashes-of-hashes, use Tie::RefHash::Nestable,
26 included as part of Tie::RefHash.
28 It is implemented using the standard perl TIEHASH interface. Please
29 see the C<tie> entry in perlfunc(1) and perltie(1) for more information.
31 The Nestable version works by looking for hash references being stored
32 and converting them to tied hashes so that they too can have
33 references as keys. This will happen without warning whenever you
34 store a reference to one of your own hashes in the tied hash.
39 tie %h, 'Tie::RefHash';
45 %h = ($a => 1, $b => 2, $c => 3, $d => 4, $e => 5);
52 tie %h, 'Tie::RefHash::Nestable';
54 for (keys %h, keys %{$h{$a}}) {
60 L<Tie::RefHash> fully supports threading using the C<CLONE> method.
62 =head1 STORABLE SUPPORT
64 L<Storable> hooks are provided for semantically correct serialization and
65 cloning of tied refhashes.
69 This version of Tie::RefHash seems to no longer work with 5.004. This has not
70 been throughly investigated. Patches welcome ;-)
74 Yuval Kogman E<lt>nothingmuch@woobling.orgE<gt>
78 Gurusamy Sarathy gsar@activestate.com
80 'Nestable' by Ed Avis ed@membled.com
84 perl(1), perlfunc(1), perltie(1)
95 # determine whether we need to take care of threads
97 my $usethreads = $Config::Config{usethreads}; # && exists $INC{"threads.pm"}
98 *_HAS_THREADS = $usethreads ? sub () { 1 } : sub () { 0 };
100 # The magic of taint tunneling means that we can't do this require in the
101 # same statement as the boolean check on $usethreads, as $usethreads is
103 require Scalar::Util;
108 # create a refaddr function
110 if ( eval { require Scalar::Util; 1 } ) {
111 Scalar::Util->import("refaddr");
116 if ( overload::StrVal($_[0]) =~ /\( 0x ([a-zA-Z0-9]+) \)$/x) {
119 die "couldn't parse StrVal: " . overload::StrVal($_[0]);
125 my (@thread_object_registry, $count); # used by the CLONE method to rehash the keys after their refaddr changed
132 $s->STORE(shift, shift);
136 # remember the object so that we can rekey it on CLONE
137 push @thread_object_registry, $s;
138 # but make this a weak reference, so that there are no leaks
139 Scalar::Util::weaken( $thread_object_registry[-1] );
141 if ( ++$count > 1000 ) {
142 # this ensures we don't fill up with a huge array dead weakrefs
143 @thread_object_registry = grep { defined } @thread_object_registry;
151 my $storable_format_version = join("/", __PACKAGE__, "0.01");
153 sub STORABLE_freeze {
154 my ( $self, $is_cloning ) = @_;
155 my ( $refs, $reg ) = @$self;
156 return ( $storable_format_version, [ values %$refs ], $reg );
160 my ( $self, $is_cloning, $version, $refs, $reg ) = @_;
161 croak "incompatible versions of Tie::RefHash between freeze and thaw"
162 unless $version eq $storable_format_version;
164 @$self = ( {}, $reg );
165 $self->_reindex_keys( $refs );
170 # when the thread has been cloned all the objects need to be updated.
171 # dead weakrefs are undefined, so we filter them out
172 @thread_object_registry = grep { defined && do { $_->_reindex_keys; 1 } } @thread_object_registry;
173 $count = 0; # we just cleaned up
177 my ( $self, $extra_keys ) = @_;
178 # rehash all the ref keys based on their new StrVal
179 %{ $self->[0] } = map { refaddr($_->[0]) => $_ } (values(%{ $self->[0] }), @{ $extra_keys || [] });
185 my $kstr = refaddr($k);
186 if (defined $s->[0]{$kstr}) {
201 $s->[0]{refaddr($k)} = [$k, $v];
212 ? (delete($s->[0]{refaddr($k)}) || [])->[1]
213 : delete($s->[1]{$k});
218 (ref $k) ? exists($s->[0]{refaddr($k)}) : exists($s->[1]{$k});
223 keys %{$s->[0]}; # reset iterator
224 keys %{$s->[1]}; # reset iterator
225 $s->[2] = 0; # flag for iteration, see NEXTKEY
233 if (($k, $v) = each %{$s->[0]}) {
240 return each %{$s->[1]};
250 package Tie::RefHash::Nestable;
252 @ISA = 'Tie::RefHash';
256 if (ref($v) eq 'HASH' and not tied %$v) {
258 tie %$v, ref($s), @elems;
260 $s->SUPER::STORE($k, $v);