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