1package Tie::RefHash;
2
3use vars qw/$VERSION/;
4
5$VERSION = "1.38";
6
7use 5.005;
8
9=head1 NAME
10
11Tie::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;
18    tie HASHVARIABLE, 'Tie::RefHash::Nestable', LIST;
19
20    untie HASHVARIABLE;
21
22=head1 DESCRIPTION
23
24This module provides the ability to use references as hash keys if you
25first C<tie> the hash variable to this module.  Normally, only the
26keys of the tied hash itself are preserved as references; to use
27references as keys in hashes-of-hashes, use Tie::RefHash::Nestable,
28included as part of Tie::RefHash.
29
30It is implemented using the standard perl TIEHASH interface.  Please
31see the C<tie> entry in perlfunc(1) and perltie(1) for more information.
32
33The Nestable version works by looking for hash references being stored
34and converting them to tied hashes so that they too can have
35references as keys.  This will happen without warning whenever you
36store a reference to one of your own hashes in the tied hash.
37
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
54    tie %h, 'Tie::RefHash::Nestable';
55    $h{$a}->{$b} = 1;
56    for (keys %h, keys %{$h{$a}}) {
57       print ref($_), "\n";
58    }
59
60=head1 THREAD SUPPORT
61
62L<Tie::RefHash> fully supports threading using the C<CLONE> method.
63
64=head1 STORABLE SUPPORT
65
66L<Storable> hooks are provided for semantically correct serialization and
67cloning of tied refhashes.
68
69=head1 RELIC SUPPORT
70
71This version of Tie::RefHash seems to no longer work with 5.004. This has not
72been throughly investigated. Patches welcome ;-)
73
74=head1 MAINTAINER
75
76Yuval Kogman E<lt>nothingmuch@woobling.orgE<gt>
77
78=head1 AUTHOR
79
80Gurusamy Sarathy        gsar@activestate.com
81
82'Nestable' by Ed Avis   ed@membled.com
83
84=head1 SEE ALSO
85
86perl(1), perlfunc(1), perltie(1)
87
88=cut
89
90use Tie::Hash;
91use vars '@ISA';
92@ISA = qw(Tie::Hash);
93use strict;
94use Carp qw/croak/;
95
96BEGIN {
97  local $@;
98  # determine whether we need to take care of threads
99  use Config ();
100  my $usethreads = $Config::Config{usethreads}; # && exists $INC{"threads.pm"}
101  *_HAS_THREADS = $usethreads ? sub () { 1 } : sub () { 0 };
102  *_HAS_SCALAR_UTIL = eval { require Scalar::Util; 1 } ? sub () { 1 } : sub () { 0 };
103  *_HAS_WEAKEN = defined(&Scalar::Util::weaken) ? sub () { 1 } : sub () { 0 };
104}
105
106BEGIN {
107  # create a refaddr function
108
109  local $@;
110
111  if ( _HAS_SCALAR_UTIL ) {
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}
125
126my (@thread_object_registry, $count); # used by the CLONE method to rehash the keys after their refaddr changed
127
128sub TIEHASH {
129  my $c = shift;
130  my $s = [];
131  bless $s, $c;
132  while (@_) {
133    $s->STORE(shift, shift);
134  }
135
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] );
143
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
151    }
152  }
153
154  return $s;
155}
156
157my $storable_format_version = join("/", __PACKAGE__, "0.01");
158
159sub STORABLE_freeze {
160  my ( $self, $is_cloning ) = @_;
161  my ( $refs, $reg ) = @$self;
162  return ( $storable_format_version, [ values %$refs ], $reg );
163}
164
165sub 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
174sub CLONE {
175  my $pkg = shift;
176
177  if ( $count and not _HAS_WEAKEN ) {
178    warn "Tie::RefHash is not threadsafe without Scalar::Util::weaken";
179  }
180
181  # when the thread has been cloned all the objects need to be updated.
182  # dead weakrefs are undefined, so we filter them out
183  @thread_object_registry = grep { defined && do { $_->_reindex_keys; 1 } } @thread_object_registry;
184  $count = 0; # we just cleaned up
185}
186
187sub _reindex_keys {
188  my ( $self, $extra_keys ) = @_;
189  # rehash all the ref keys based on their new StrVal
190  %{ $self->[0] } = map { refaddr($_->[0]) => $_ } (values(%{ $self->[0] }), @{ $extra_keys || [] });
191}
192
193sub FETCH {
194  my($s, $k) = @_;
195  if (ref $k) {
196      my $kstr = refaddr($k);
197      if (defined $s->[0]{$kstr}) {
198        $s->[0]{$kstr}[1];
199      }
200      else {
201        undef;
202      }
203  }
204  else {
205      $s->[1]{$k};
206  }
207}
208
209sub STORE {
210  my($s, $k, $v) = @_;
211  if (ref $k) {
212    $s->[0]{refaddr($k)} = [$k, $v];
213  }
214  else {
215    $s->[1]{$k} = $v;
216  }
217  $v;
218}
219
220sub DELETE {
221  my($s, $k) = @_;
222  (ref $k)
223    ? (delete($s->[0]{refaddr($k)}) || [])->[1]
224    : delete($s->[1]{$k});
225}
226
227sub EXISTS {
228  my($s, $k) = @_;
229  (ref $k) ? exists($s->[0]{refaddr($k)}) : exists($s->[1]{$k});
230}
231
232sub FIRSTKEY {
233  my $s = shift;
234  keys %{$s->[0]};  # reset iterator
235  keys %{$s->[1]};  # reset iterator
236  $s->[2] = 0;      # flag for iteration, see NEXTKEY
237  $s->NEXTKEY;
238}
239
240sub NEXTKEY {
241  my $s = shift;
242  my ($k, $v);
243  if (!$s->[2]) {
244    if (($k, $v) = each %{$s->[0]}) {
245      return $v->[0];
246    }
247    else {
248      $s->[2] = 1;
249    }
250  }
251  return each %{$s->[1]};
252}
253
254sub CLEAR {
255  my $s = shift;
256  $s->[2] = 0;
257  %{$s->[0]} = ();
258  %{$s->[1]} = ();
259}
260
261package Tie::RefHash::Nestable;
262use vars '@ISA';
263@ISA = 'Tie::RefHash';
264
265sub 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
2741;
275