1package Tie::RefHash;
2
3use vars qw/$VERSION/;
4
5$VERSION = "1.39";
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 LICENSE
75
76This program is free software; you can redistribute it and/or modify it under
77the same terms as Perl itself
78
79=head1 MAINTAINER
80
81Yuval Kogman E<lt>nothingmuch@woobling.orgE<gt>
82
83=head1 AUTHOR
84
85Gurusamy Sarathy        gsar@activestate.com
86
87'Nestable' by Ed Avis   ed@membled.com
88
89=head1 SEE ALSO
90
91perl(1), perlfunc(1), perltie(1)
92
93=cut
94
95use Tie::Hash;
96use vars '@ISA';
97@ISA = qw(Tie::Hash);
98use strict;
99use Carp qw/croak/;
100
101BEGIN {
102  local $@;
103  # determine whether we need to take care of threads
104  use Config ();
105  my $usethreads = $Config::Config{usethreads}; # && exists $INC{"threads.pm"}
106  *_HAS_THREADS = $usethreads ? sub () { 1 } : sub () { 0 };
107  *_HAS_SCALAR_UTIL = eval { require Scalar::Util; 1 } ? sub () { 1 } : sub () { 0 };
108  *_HAS_WEAKEN = defined(&Scalar::Util::weaken) ? sub () { 1 } : sub () { 0 };
109}
110
111BEGIN {
112  # create a refaddr function
113
114  local $@;
115
116  if ( _HAS_SCALAR_UTIL ) {
117    Scalar::Util->import("refaddr");
118  } else {
119    require overload;
120
121    *refaddr = sub {
122      if ( overload::StrVal($_[0]) =~ /\( 0x ([a-zA-Z0-9]+) \)$/x) {
123          return $1;
124      } else {
125        die "couldn't parse StrVal: " . overload::StrVal($_[0]);
126      }
127    };
128  }
129}
130
131my (@thread_object_registry, $count); # used by the CLONE method to rehash the keys after their refaddr changed
132
133sub TIEHASH {
134  my $c = shift;
135  my $s = [];
136  bless $s, $c;
137  while (@_) {
138    $s->STORE(shift, shift);
139  }
140
141  if (_HAS_THREADS ) {
142
143    if ( _HAS_WEAKEN ) {
144      # remember the object so that we can rekey it on CLONE
145      push @thread_object_registry, $s;
146      # but make this a weak reference, so that there are no leaks
147      Scalar::Util::weaken( $thread_object_registry[-1] );
148
149      if ( ++$count > 1000 ) {
150        # this ensures we don't fill up with a huge array dead weakrefs
151        @thread_object_registry = grep { defined } @thread_object_registry;
152        $count = 0;
153      }
154    } else {
155      $count++; # used in the warning
156    }
157  }
158
159  return $s;
160}
161
162my $storable_format_version = join("/", __PACKAGE__, "0.01");
163
164sub STORABLE_freeze {
165  my ( $self, $is_cloning ) = @_;
166  my ( $refs, $reg ) = @$self;
167  return ( $storable_format_version, [ values %$refs ], $reg || {} );
168}
169
170sub STORABLE_thaw {
171  my ( $self, $is_cloning, $version, $refs, $reg ) = @_;
172  croak "incompatible versions of Tie::RefHash between freeze and thaw"
173    unless $version eq $storable_format_version;
174
175  @$self = ( {}, $reg );
176  $self->_reindex_keys( $refs );
177}
178
179sub CLONE {
180  my $pkg = shift;
181
182  if ( $count and not _HAS_WEAKEN ) {
183    warn "Tie::RefHash is not threadsafe without Scalar::Util::weaken";
184  }
185
186  # when the thread has been cloned all the objects need to be updated.
187  # dead weakrefs are undefined, so we filter them out
188  @thread_object_registry = grep { defined && do { $_->_reindex_keys; 1 } } @thread_object_registry;
189  $count = 0; # we just cleaned up
190}
191
192sub _reindex_keys {
193  my ( $self, $extra_keys ) = @_;
194  # rehash all the ref keys based on their new StrVal
195  %{ $self->[0] } = map { refaddr($_->[0]) => $_ } (values(%{ $self->[0] }), @{ $extra_keys || [] });
196}
197
198sub FETCH {
199  my($s, $k) = @_;
200  if (ref $k) {
201      my $kstr = refaddr($k);
202      if (defined $s->[0]{$kstr}) {
203        $s->[0]{$kstr}[1];
204      }
205      else {
206        undef;
207      }
208  }
209  else {
210      $s->[1]{$k};
211  }
212}
213
214sub STORE {
215  my($s, $k, $v) = @_;
216  if (ref $k) {
217    $s->[0]{refaddr($k)} = [$k, $v];
218  }
219  else {
220    $s->[1]{$k} = $v;
221  }
222  $v;
223}
224
225sub DELETE {
226  my($s, $k) = @_;
227  (ref $k)
228    ? (delete($s->[0]{refaddr($k)}) || [])->[1]
229    : delete($s->[1]{$k});
230}
231
232sub EXISTS {
233  my($s, $k) = @_;
234  (ref $k) ? exists($s->[0]{refaddr($k)}) : exists($s->[1]{$k});
235}
236
237sub FIRSTKEY {
238  my $s = shift;
239  keys %{$s->[0]};  # reset iterator
240  keys %{$s->[1]};  # reset iterator
241  $s->[2] = 0;      # flag for iteration, see NEXTKEY
242  $s->NEXTKEY;
243}
244
245sub NEXTKEY {
246  my $s = shift;
247  my ($k, $v);
248  if (!$s->[2]) {
249    if (($k, $v) = each %{$s->[0]}) {
250      return $v->[0];
251    }
252    else {
253      $s->[2] = 1;
254    }
255  }
256  return each %{$s->[1]};
257}
258
259sub CLEAR {
260  my $s = shift;
261  $s->[2] = 0;
262  %{$s->[0]} = ();
263  %{$s->[1]} = ();
264}
265
266package Tie::RefHash::Nestable;
267use vars '@ISA';
268@ISA = 'Tie::RefHash';
269
270sub STORE {
271  my($s, $k, $v) = @_;
272  if (ref($v) eq 'HASH' and not tied %$v) {
273      my @elems = %$v;
274      tie %$v, ref($s), @elems;
275  }
276  $s->SUPER::STORE($k, $v);
277}
278
2791;
280