Commit | Line | Data |
5f05dabc |
1 | package Tie::RefHash; |
2 | |
893374f6 |
3 | our $VERSION = 1.33; |
b75c8c73 |
4 | |
5f05dabc |
5 | =head1 NAME |
6 | |
7 | Tie::RefHash - use references as hash keys |
8 | |
9 | =head1 SYNOPSIS |
10 | |
11 | require 5.004; |
12 | use Tie::RefHash; |
13 | tie HASHVARIABLE, 'Tie::RefHash', LIST; |
778e8f97 |
14 | tie HASHVARIABLE, 'Tie::RefHash::Nestable', LIST; |
5f05dabc |
15 | |
16 | untie HASHVARIABLE; |
17 | |
18 | =head1 DESCRIPTION |
19 | |
778e8f97 |
20 | This module provides the ability to use references as hash keys if you |
21 | first C<tie> the hash variable to this module. Normally, only the |
22 | keys of the tied hash itself are preserved as references; to use |
23 | references as keys in hashes-of-hashes, use Tie::RefHash::Nestable, |
8b2fd6cc |
24 | included as part of Tie::RefHash. |
5f05dabc |
25 | |
26 | It is implemented using the standard perl TIEHASH interface. Please |
27 | see the C<tie> entry in perlfunc(1) and perltie(1) for more information. |
28 | |
778e8f97 |
29 | The Nestable version works by looking for hash references being stored |
30 | and converting them to tied hashes so that they too can have |
31 | references as keys. This will happen without warning whenever you |
32 | store a reference to one of your own hashes in the tied hash. |
33 | |
5f05dabc |
34 | =head1 EXAMPLE |
35 | |
36 | use Tie::RefHash; |
37 | tie %h, 'Tie::RefHash'; |
38 | $a = []; |
39 | $b = {}; |
40 | $c = \*main; |
41 | $d = \"gunk"; |
42 | $e = sub { 'foo' }; |
43 | %h = ($a => 1, $b => 2, $c => 3, $d => 4, $e => 5); |
44 | $a->[0] = 'foo'; |
45 | $b->{foo} = 'bar'; |
46 | for (keys %h) { |
47 | print ref($_), "\n"; |
48 | } |
49 | |
778e8f97 |
50 | tie %h, 'Tie::RefHash::Nestable'; |
51 | $h{$a}->{$b} = 1; |
52 | for (keys %h, keys %{$h{$a}}) { |
53 | print ref($_), "\n"; |
54 | } |
5f05dabc |
55 | |
56 | =head1 AUTHOR |
57 | |
da41ffc5 |
58 | Gurusamy Sarathy gsar@activestate.com |
5f05dabc |
59 | |
d3f88289 |
60 | 'Nestable' by Ed Avis ed@membled.com |
61 | |
5f05dabc |
62 | =head1 SEE ALSO |
63 | |
64 | perl(1), perlfunc(1), perltie(1) |
65 | |
66 | =cut |
67 | |
5f05dabc |
68 | use Tie::Hash; |
8b2fd6cc |
69 | use vars '@ISA'; |
5f05dabc |
70 | @ISA = qw(Tie::Hash); |
71 | use strict; |
72 | |
893374f6 |
73 | BEGIN { |
74 | use Config (); |
75 | my $usethreads = $Config::Config{usethreads}; # && exists $INC{"threads.pm"} |
76 | *_HAS_THREADS = $usethreads ? sub () { 1 } : sub () { 0 }; |
77 | require Scalar::Util if $usethreads; # we need weaken() |
78 | } |
79 | |
05d3035d |
80 | require overload; # to support objects with overloaded "" |
60ad8d77 |
81 | |
893374f6 |
82 | my (@thread_object_registry, $count); # used by the CLONE method to rehash the keys after their refaddr changed |
83 | |
5f05dabc |
84 | sub TIEHASH { |
85 | my $c = shift; |
86 | my $s = []; |
87 | bless $s, $c; |
88 | while (@_) { |
89 | $s->STORE(shift, shift); |
90 | } |
893374f6 |
91 | |
92 | if (_HAS_THREADS) { |
93 | # remember the object so that we can rekey it on CLONE |
94 | push @thread_object_registry, $s; |
95 | # but make this a weak reference, so that there are no leaks |
96 | Scalar::Util::weaken( $thread_object_registry[-1] ); |
97 | |
98 | if ( ++$count > 1000 ) { |
99 | # this ensures we don't fill up with a huge array dead weakrefs |
100 | @thread_object_registry = grep { defined } @thread_object_registry; |
101 | $count = 0; |
102 | } |
103 | } |
104 | |
5f05dabc |
105 | return $s; |
106 | } |
107 | |
893374f6 |
108 | sub CLONE { |
109 | my $pkg = shift; |
110 | # when the thread has been cloned all the objects need to be updated. |
111 | # dead weakrefs are undefined, so we filter them out |
112 | @thread_object_registry = grep { defined && do { $_->CLONE_OBJ; 1 } } @thread_object_registry; |
113 | $count = 0; # we just cleaned up |
114 | } |
115 | |
116 | sub CLONE_OBJ { |
117 | my $self = shift; |
118 | # rehash all the ref keys based on their new StrVal |
119 | %{ $self->[0] } = map { overload::StrVal($_->[0]) => $_ } values %{ $self->[0] }; |
120 | } |
121 | |
5f05dabc |
122 | sub FETCH { |
123 | my($s, $k) = @_; |
778e8f97 |
124 | if (ref $k) { |
60ad8d77 |
125 | my $kstr = overload::StrVal($k); |
126 | if (defined $s->[0]{$kstr}) { |
127 | $s->[0]{$kstr}[1]; |
778e8f97 |
128 | } |
129 | else { |
130 | undef; |
131 | } |
132 | } |
133 | else { |
134 | $s->[1]{$k}; |
135 | } |
5f05dabc |
136 | } |
137 | |
138 | sub STORE { |
139 | my($s, $k, $v) = @_; |
140 | if (ref $k) { |
60ad8d77 |
141 | $s->[0]{overload::StrVal($k)} = [$k, $v]; |
5f05dabc |
142 | } |
143 | else { |
144 | $s->[1]{$k} = $v; |
145 | } |
146 | $v; |
147 | } |
148 | |
149 | sub DELETE { |
150 | my($s, $k) = @_; |
18592d64 |
151 | (ref $k) |
152 | ? (delete($s->[0]{overload::StrVal($k)}) || [])->[1] |
153 | : delete($s->[1]{$k}); |
5f05dabc |
154 | } |
155 | |
156 | sub EXISTS { |
157 | my($s, $k) = @_; |
60ad8d77 |
158 | (ref $k) ? exists($s->[0]{overload::StrVal($k)}) : exists($s->[1]{$k}); |
5f05dabc |
159 | } |
160 | |
161 | sub FIRSTKEY { |
162 | my $s = shift; |
da41ffc5 |
163 | keys %{$s->[0]}; # reset iterator |
164 | keys %{$s->[1]}; # reset iterator |
60ad8d77 |
165 | $s->[2] = 0; # flag for iteration, see NEXTKEY |
5f05dabc |
166 | $s->NEXTKEY; |
167 | } |
168 | |
169 | sub NEXTKEY { |
170 | my $s = shift; |
171 | my ($k, $v); |
172 | if (!$s->[2]) { |
173 | if (($k, $v) = each %{$s->[0]}) { |
60ad8d77 |
174 | return $v->[0]; |
5f05dabc |
175 | } |
176 | else { |
177 | $s->[2] = 1; |
178 | } |
179 | } |
180 | return each %{$s->[1]}; |
181 | } |
182 | |
183 | sub CLEAR { |
184 | my $s = shift; |
185 | $s->[2] = 0; |
186 | %{$s->[0]} = (); |
187 | %{$s->[1]} = (); |
188 | } |
189 | |
778e8f97 |
190 | package Tie::RefHash::Nestable; |
8b2fd6cc |
191 | use vars '@ISA'; |
192 | @ISA = 'Tie::RefHash'; |
778e8f97 |
193 | |
194 | sub STORE { |
195 | my($s, $k, $v) = @_; |
196 | if (ref($v) eq 'HASH' and not tied %$v) { |
197 | my @elems = %$v; |
198 | tie %$v, ref($s), @elems; |
199 | } |
200 | $s->SUPER::STORE($k, $v); |
201 | } |
202 | |
5f05dabc |
203 | 1; |