Commit | Line | Data |
---|---|---|
5f05dabc | 1 | package Tie::RefHash; |
2 | ||
f0f40d86 RGS |
3 | use vars qw/$VERSION/; |
4 | ||
a327f6f7 | 5 | $VERSION = "1.34_01"; |
b75c8c73 | 6 | |
5f05dabc | 7 | =head1 NAME |
8 | ||
9 | Tie::RefHash - use references as hash keys | |
10 | ||
11 | =head1 SYNOPSIS | |
12 | ||
13 | require 5.004; | |
14 | use Tie::RefHash; | |
15 | tie HASHVARIABLE, 'Tie::RefHash', LIST; | |
778e8f97 | 16 | tie HASHVARIABLE, 'Tie::RefHash::Nestable', LIST; |
5f05dabc | 17 | |
18 | untie HASHVARIABLE; | |
19 | ||
20 | =head1 DESCRIPTION | |
21 | ||
778e8f97 EA |
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, | |
8b2fd6cc | 26 | included as part of Tie::RefHash. |
5f05dabc | 27 | |
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. | |
30 | ||
778e8f97 EA |
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. | |
35 | ||
5f05dabc | 36 | =head1 EXAMPLE |
37 | ||
38 | use Tie::RefHash; | |
39 | tie %h, 'Tie::RefHash'; | |
40 | $a = []; | |
41 | $b = {}; | |
42 | $c = \*main; | |
43 | $d = \"gunk"; | |
44 | $e = sub { 'foo' }; | |
45 | %h = ($a => 1, $b => 2, $c => 3, $d => 4, $e => 5); | |
46 | $a->[0] = 'foo'; | |
47 | $b->{foo} = 'bar'; | |
48 | for (keys %h) { | |
49 | print ref($_), "\n"; | |
50 | } | |
51 | ||
778e8f97 EA |
52 | tie %h, 'Tie::RefHash::Nestable'; |
53 | $h{$a}->{$b} = 1; | |
54 | for (keys %h, keys %{$h{$a}}) { | |
55 | print ref($_), "\n"; | |
56 | } | |
5f05dabc | 57 | |
f0f40d86 RGS |
58 | =head1 THREAD SUPPORT |
59 | ||
60 | L<Tie::RefHash> fully supports threading using the C<CLONE> method. | |
61 | ||
62 | =head1 STORABLE SUPPORT | |
63 | ||
64 | L<Storable> hooks are provided for semantically correct serialization and | |
65 | cloning of tied refhashes. | |
66 | ||
67 | =head1 RELIC SUPPORT | |
68 | ||
69 | This version of Tie::RefHash seems to no longer work with 5.004. This has not | |
70 | been throughly investigated. Patches welcome ;-) | |
71 | ||
72 | =head1 MAINTAINER | |
73 | ||
74 | Yuval Kogman E<lt>nothingmuch@woobling.orgE<gt> | |
75 | ||
5f05dabc | 76 | =head1 AUTHOR |
77 | ||
da41ffc5 | 78 | Gurusamy Sarathy gsar@activestate.com |
5f05dabc | 79 | |
d3f88289 EA |
80 | 'Nestable' by Ed Avis ed@membled.com |
81 | ||
5f05dabc | 82 | =head1 SEE ALSO |
83 | ||
84 | perl(1), perlfunc(1), perltie(1) | |
85 | ||
86 | =cut | |
87 | ||
5f05dabc | 88 | use Tie::Hash; |
8b2fd6cc | 89 | use vars '@ISA'; |
5f05dabc | 90 | @ISA = qw(Tie::Hash); |
91 | use strict; | |
f0f40d86 | 92 | use Carp qw/croak/; |
5f05dabc | 93 | |
893374f6 | 94 | BEGIN { |
f0f40d86 | 95 | # determine whether we need to take care of threads |
893374f6 YK |
96 | use Config (); |
97 | my $usethreads = $Config::Config{usethreads}; # && exists $INC{"threads.pm"} | |
98 | *_HAS_THREADS = $usethreads ? sub () { 1 } : sub () { 0 }; | |
a327f6f7 NC |
99 | if ($usethreads) { |
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 | |
102 | # tainted. | |
103 | require Scalar::Util; | |
104 | } | |
893374f6 YK |
105 | } |
106 | ||
f0f40d86 RGS |
107 | BEGIN { |
108 | # create a refaddr function | |
109 | ||
110 | if ( eval { require Scalar::Util; 1 } ) { | |
111 | Scalar::Util->import("refaddr"); | |
112 | } else { | |
113 | require overload; | |
114 | ||
115 | *refaddr = sub { | |
116 | if ( overload::StrVal($_[0]) =~ /\( 0x ([a-zA-Z0-9]+) \)$/x) { | |
117 | return $1; | |
118 | } else { | |
119 | die "couldn't parse StrVal: " . overload::StrVal($_[0]); | |
120 | } | |
121 | }; | |
122 | } | |
123 | } | |
60ad8d77 | 124 | |
893374f6 YK |
125 | my (@thread_object_registry, $count); # used by the CLONE method to rehash the keys after their refaddr changed |
126 | ||
5f05dabc | 127 | sub TIEHASH { |
128 | my $c = shift; | |
129 | my $s = []; | |
130 | bless $s, $c; | |
131 | while (@_) { | |
132 | $s->STORE(shift, shift); | |
133 | } | |
893374f6 YK |
134 | |
135 | if (_HAS_THREADS) { | |
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] ); | |
140 | ||
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; | |
144 | $count = 0; | |
145 | } | |
146 | } | |
147 | ||
5f05dabc | 148 | return $s; |
149 | } | |
150 | ||
f0f40d86 RGS |
151 | my $storable_format_version = join("/", __PACKAGE__, "0.01"); |
152 | ||
153 | sub STORABLE_freeze { | |
154 | my ( $self, $is_cloning ) = @_; | |
155 | my ( $refs, $reg ) = @$self; | |
156 | return ( $storable_format_version, [ values %$refs ], $reg ); | |
157 | } | |
158 | ||
159 | sub STORABLE_thaw { | |
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; | |
163 | ||
164 | @$self = ( {}, $reg ); | |
165 | $self->_reindex_keys( $refs ); | |
166 | } | |
167 | ||
893374f6 YK |
168 | sub CLONE { |
169 | my $pkg = shift; | |
170 | # when the thread has been cloned all the objects need to be updated. | |
171 | # dead weakrefs are undefined, so we filter them out | |
f0f40d86 | 172 | @thread_object_registry = grep { defined && do { $_->_reindex_keys; 1 } } @thread_object_registry; |
893374f6 YK |
173 | $count = 0; # we just cleaned up |
174 | } | |
175 | ||
f0f40d86 RGS |
176 | sub _reindex_keys { |
177 | my ( $self, $extra_keys ) = @_; | |
893374f6 | 178 | # rehash all the ref keys based on their new StrVal |
f0f40d86 | 179 | %{ $self->[0] } = map { refaddr($_->[0]) => $_ } (values(%{ $self->[0] }), @{ $extra_keys || [] }); |
893374f6 YK |
180 | } |
181 | ||
5f05dabc | 182 | sub FETCH { |
183 | my($s, $k) = @_; | |
778e8f97 | 184 | if (ref $k) { |
f0f40d86 | 185 | my $kstr = refaddr($k); |
60ad8d77 XN |
186 | if (defined $s->[0]{$kstr}) { |
187 | $s->[0]{$kstr}[1]; | |
778e8f97 EA |
188 | } |
189 | else { | |
190 | undef; | |
191 | } | |
192 | } | |
193 | else { | |
194 | $s->[1]{$k}; | |
195 | } | |
5f05dabc | 196 | } |
197 | ||
198 | sub STORE { | |
199 | my($s, $k, $v) = @_; | |
200 | if (ref $k) { | |
f0f40d86 | 201 | $s->[0]{refaddr($k)} = [$k, $v]; |
5f05dabc | 202 | } |
203 | else { | |
204 | $s->[1]{$k} = $v; | |
205 | } | |
206 | $v; | |
207 | } | |
208 | ||
209 | sub DELETE { | |
210 | my($s, $k) = @_; | |
18592d64 | 211 | (ref $k) |
f0f40d86 | 212 | ? (delete($s->[0]{refaddr($k)}) || [])->[1] |
18592d64 | 213 | : delete($s->[1]{$k}); |
5f05dabc | 214 | } |
215 | ||
216 | sub EXISTS { | |
217 | my($s, $k) = @_; | |
f0f40d86 | 218 | (ref $k) ? exists($s->[0]{refaddr($k)}) : exists($s->[1]{$k}); |
5f05dabc | 219 | } |
220 | ||
221 | sub FIRSTKEY { | |
222 | my $s = shift; | |
f0f40d86 RGS |
223 | keys %{$s->[0]}; # reset iterator |
224 | keys %{$s->[1]}; # reset iterator | |
60ad8d77 | 225 | $s->[2] = 0; # flag for iteration, see NEXTKEY |
5f05dabc | 226 | $s->NEXTKEY; |
227 | } | |
228 | ||
229 | sub NEXTKEY { | |
230 | my $s = shift; | |
231 | my ($k, $v); | |
232 | if (!$s->[2]) { | |
233 | if (($k, $v) = each %{$s->[0]}) { | |
60ad8d77 | 234 | return $v->[0]; |
5f05dabc | 235 | } |
236 | else { | |
237 | $s->[2] = 1; | |
238 | } | |
239 | } | |
240 | return each %{$s->[1]}; | |
241 | } | |
242 | ||
243 | sub CLEAR { | |
244 | my $s = shift; | |
245 | $s->[2] = 0; | |
246 | %{$s->[0]} = (); | |
247 | %{$s->[1]} = (); | |
248 | } | |
249 | ||
778e8f97 | 250 | package Tie::RefHash::Nestable; |
8b2fd6cc JH |
251 | use vars '@ISA'; |
252 | @ISA = 'Tie::RefHash'; | |
778e8f97 EA |
253 | |
254 | sub STORE { | |
255 | my($s, $k, $v) = @_; | |
256 | if (ref($v) eq 'HASH' and not tied %$v) { | |
257 | my @elems = %$v; | |
258 | tie %$v, ref($s), @elems; | |
259 | } | |
260 | $s->SUPER::STORE($k, $v); | |
261 | } | |
262 | ||
5f05dabc | 263 | 1; |