Commit | Line | Data |
5f05dabc |
1 | package Tie::RefHash; |
2 | |
f0f40d86 |
3 | use vars qw/$VERSION/; |
4 | |
4e87bc57 |
5 | $VERSION = "1.35_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 |
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 |
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 |
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 |
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 |
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 |
96 | use Config (); |
97 | my $usethreads = $Config::Config{usethreads}; # && exists $INC{"threads.pm"} |
98 | *_HAS_THREADS = $usethreads ? sub () { 1 } : sub () { 0 }; |
a327f6f7 |
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 |
105 | } |
106 | |
f0f40d86 |
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 |
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 |
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 |
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 |
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 |
173 | $count = 0; # we just cleaned up |
174 | } |
175 | |
f0f40d86 |
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 |
180 | } |
181 | |
5f05dabc |
182 | sub FETCH { |
183 | my($s, $k) = @_; |
778e8f97 |
184 | if (ref $k) { |
f0f40d86 |
185 | my $kstr = refaddr($k); |
60ad8d77 |
186 | if (defined $s->[0]{$kstr}) { |
187 | $s->[0]{$kstr}[1]; |
778e8f97 |
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 |
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 |
251 | use vars '@ISA'; |
252 | @ISA = 'Tie::RefHash'; |
778e8f97 |
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; |