11 Tie::RefHash - use references as hash keys
17 tie HASHVARIABLE, 'Tie::RefHash', LIST;
18 tie HASHVARIABLE, 'Tie::RefHash::Nestable', LIST;
24 This module provides the ability to use references as hash keys if you
25 first C<tie> the hash variable to this module. Normally, only the
26 keys of the tied hash itself are preserved as references; to use
27 references as keys in hashes-of-hashes, use Tie::RefHash::Nestable,
28 included as part of Tie::RefHash.
30 It is implemented using the standard perl TIEHASH interface. Please
31 see the C<tie> entry in perlfunc(1) and perltie(1) for more information.
33 The Nestable version works by looking for hash references being stored
34 and converting them to tied hashes so that they too can have
35 references as keys. This will happen without warning whenever you
36 store a reference to one of your own hashes in the tied hash.
41 tie %h, 'Tie::RefHash';
47 %h = ($a => 1, $b => 2, $c => 3, $d => 4, $e => 5);
54 tie %h, 'Tie::RefHash::Nestable';
56 for (keys %h, keys %{$h{$a}}) {
62 L<Tie::RefHash> fully supports threading using the C<CLONE> method.
64 =head1 STORABLE SUPPORT
66 L<Storable> hooks are provided for semantically correct serialization and
67 cloning of tied refhashes.
71 This version of Tie::RefHash seems to no longer work with 5.004. This has not
72 been throughly investigated. Patches welcome ;-)
76 Yuval Kogman E<lt>nothingmuch@woobling.orgE<gt>
80 Gurusamy Sarathy gsar@activestate.com
82 'Nestable' by Ed Avis ed@membled.com
86 perl(1), perlfunc(1), perltie(1)
98 # determine whether we need to take care of threads
100 my $usethreads = $Config::Config{usethreads}; # && exists $INC{"threads.pm"}
101 *_HAS_THREADS = $usethreads ? sub () { 1 } : sub () { 0 };
102 *_HAS_SCALAR_UTIL = eval { require Scalar::Util; 1 } ? sub () { 1 } : sub () { 0 };
103 *_HAS_WEAKEN = defined(&Scalar::Util::weaken) ? sub () { 1 } : sub () { 0 };
107 # create a refaddr function
111 if ( _HAS_SCALAR_UTIL ) {
112 Scalar::Util->import("refaddr");
117 if ( overload::StrVal($_[0]) =~ /\( 0x ([a-zA-Z0-9]+) \)$/x) {
120 die "couldn't parse StrVal: " . overload::StrVal($_[0]);
126 my (@thread_object_registry, $count); # used by the CLONE method to rehash the keys after their refaddr changed
133 $s->STORE(shift, shift);
139 # remember the object so that we can rekey it on CLONE
140 push @thread_object_registry, $s;
141 # but make this a weak reference, so that there are no leaks
142 Scalar::Util::weaken( $thread_object_registry[-1] );
144 if ( ++$count > 1000 ) {
145 # this ensures we don't fill up with a huge array dead weakrefs
146 @thread_object_registry = grep { defined } @thread_object_registry;
150 $count++; # used in the warning
157 my $storable_format_version = join("/", __PACKAGE__, "0.01");
159 sub STORABLE_freeze {
160 my ( $self, $is_cloning ) = @_;
161 my ( $refs, $reg ) = @$self;
162 return ( $storable_format_version, [ values %$refs ], $reg );
166 my ( $self, $is_cloning, $version, $refs, $reg ) = @_;
167 croak "incompatible versions of Tie::RefHash between freeze and thaw"
168 unless $version eq $storable_format_version;
170 @$self = ( {}, $reg );
171 $self->_reindex_keys( $refs );
177 if ( $count and not _HAS_WEAKEN ) {
178 warn "Tie::RefHash is not threadsafe without Scalar::Util::weaken";
181 # when the thread has been cloned all the objects need to be updated.
182 # dead weakrefs are undefined, so we filter them out
183 @thread_object_registry = grep { defined && do { $_->_reindex_keys; 1 } } @thread_object_registry;
184 $count = 0; # we just cleaned up
188 my ( $self, $extra_keys ) = @_;
189 # rehash all the ref keys based on their new StrVal
190 %{ $self->[0] } = map { refaddr($_->[0]) => $_ } (values(%{ $self->[0] }), @{ $extra_keys || [] });
196 my $kstr = refaddr($k);
197 if (defined $s->[0]{$kstr}) {
212 $s->[0]{refaddr($k)} = [$k, $v];
223 ? (delete($s->[0]{refaddr($k)}) || [])->[1]
224 : delete($s->[1]{$k});
229 (ref $k) ? exists($s->[0]{refaddr($k)}) : exists($s->[1]{$k});
234 keys %{$s->[0]}; # reset iterator
235 keys %{$s->[1]}; # reset iterator
236 $s->[2] = 0; # flag for iteration, see NEXTKEY
244 if (($k, $v) = each %{$s->[0]}) {
251 return each %{$s->[1]};
261 package Tie::RefHash::Nestable;
263 @ISA = 'Tie::RefHash';
267 if (ref($v) eq 'HASH' and not tied %$v) {
269 tie %$v, ref($s), @elems;
271 $s->SUPER::STORE($k, $v);