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 };
99 require Scalar::Util if $usethreads; # we need weaken()
103 # create a refaddr function
105 if ( eval { require Scalar::Util; 1 } ) {
106 Scalar::Util->import("refaddr");
111 if ( overload::StrVal($_[0]) =~ /\( 0x ([a-zA-Z0-9]+) \)$/x) {
114 die "couldn't parse StrVal: " . overload::StrVal($_[0]);
120 my (@thread_object_registry, $count); # used by the CLONE method to rehash the keys after their refaddr changed
127 $s->STORE(shift, shift);
131 # remember the object so that we can rekey it on CLONE
132 push @thread_object_registry, $s;
133 # but make this a weak reference, so that there are no leaks
134 Scalar::Util::weaken( $thread_object_registry[-1] );
136 if ( ++$count > 1000 ) {
137 # this ensures we don't fill up with a huge array dead weakrefs
138 @thread_object_registry = grep { defined } @thread_object_registry;
146 my $storable_format_version = join("/", __PACKAGE__, "0.01");
148 sub STORABLE_freeze {
149 my ( $self, $is_cloning ) = @_;
150 my ( $refs, $reg ) = @$self;
151 return ( $storable_format_version, [ values %$refs ], $reg );
155 my ( $self, $is_cloning, $version, $refs, $reg ) = @_;
156 croak "incompatible versions of Tie::RefHash between freeze and thaw"
157 unless $version eq $storable_format_version;
159 @$self = ( {}, $reg );
160 $self->_reindex_keys( $refs );
165 # when the thread has been cloned all the objects need to be updated.
166 # dead weakrefs are undefined, so we filter them out
167 @thread_object_registry = grep { defined && do { $_->_reindex_keys; 1 } } @thread_object_registry;
168 $count = 0; # we just cleaned up
172 my ( $self, $extra_keys ) = @_;
173 # rehash all the ref keys based on their new StrVal
174 %{ $self->[0] } = map { refaddr($_->[0]) => $_ } (values(%{ $self->[0] }), @{ $extra_keys || [] });
180 my $kstr = refaddr($k);
181 if (defined $s->[0]{$kstr}) {
196 $s->[0]{refaddr($k)} = [$k, $v];
207 ? (delete($s->[0]{refaddr($k)}) || [])->[1]
208 : delete($s->[1]{$k});
213 (ref $k) ? exists($s->[0]{refaddr($k)}) : exists($s->[1]{$k});
218 keys %{$s->[0]}; # reset iterator
219 keys %{$s->[1]}; # reset iterator
220 $s->[2] = 0; # flag for iteration, see NEXTKEY
228 if (($k, $v) = each %{$s->[0]}) {
235 return each %{$s->[1]};
245 package Tie::RefHash::Nestable;
247 @ISA = 'Tie::RefHash';
251 if (ref($v) eq 'HASH' and not tied %$v) {
253 tie %$v, ref($s), @elems;
255 $s->SUPER::STORE($k, $v);