1package Tie::RefHash; # git description: Tie-RefHash-1.39-10-g2cfa4bd
2# ABSTRACT: Use references as hash keys
3
4our $VERSION = '1.40';
5
6#pod =head1 SYNOPSIS
7#pod
8#pod     require 5.004;
9#pod     use Tie::RefHash;
10#pod     tie HASHVARIABLE, 'Tie::RefHash', LIST;
11#pod     tie HASHVARIABLE, 'Tie::RefHash::Nestable', LIST;
12#pod
13#pod     untie HASHVARIABLE;
14#pod
15#pod =head1 DESCRIPTION
16#pod
17#pod This module provides the ability to use references as hash keys if you
18#pod first C<tie> the hash variable to this module.  Normally, only the
19#pod keys of the tied hash itself are preserved as references; to use
20#pod references as keys in hashes-of-hashes, use Tie::RefHash::Nestable,
21#pod included as part of Tie::RefHash.
22#pod
23#pod It is implemented using the standard perl TIEHASH interface.  Please
24#pod see the C<tie> entry in perlfunc(1) and perltie(1) for more information.
25#pod
26#pod The Nestable version works by looking for hash references being stored
27#pod and converting them to tied hashes so that they too can have
28#pod references as keys.  This will happen without warning whenever you
29#pod store a reference to one of your own hashes in the tied hash.
30#pod
31#pod =head1 EXAMPLE
32#pod
33#pod     use Tie::RefHash;
34#pod     tie %h, 'Tie::RefHash';
35#pod     $a = [];
36#pod     $b = {};
37#pod     $c = \*main;
38#pod     $d = \"gunk";
39#pod     $e = sub { 'foo' };
40#pod     %h = ($a => 1, $b => 2, $c => 3, $d => 4, $e => 5);
41#pod     $a->[0] = 'foo';
42#pod     $b->{foo} = 'bar';
43#pod     for (keys %h) {
44#pod        print ref($_), "\n";
45#pod     }
46#pod
47#pod     tie %h, 'Tie::RefHash::Nestable';
48#pod     $h{$a}->{$b} = 1;
49#pod     for (keys %h, keys %{$h{$a}}) {
50#pod        print ref($_), "\n";
51#pod     }
52#pod
53#pod =head1 THREAD SUPPORT
54#pod
55#pod L<Tie::RefHash> fully supports threading using the C<CLONE> method.
56#pod
57#pod =head1 STORABLE SUPPORT
58#pod
59#pod L<Storable> hooks are provided for semantically correct serialization and
60#pod cloning of tied refhashes.
61#pod
62#pod =head1 AUTHORS
63#pod
64#pod Gurusamy Sarathy <gsar@activestate.com>
65#pod
66#pod Tie::RefHash::Nestable by Ed Avis <ed@membled.com>
67#pod
68#pod =head1 SEE ALSO
69#pod
70#pod perl(1), perlfunc(1), perltie(1)
71#pod
72#pod =cut
73
74use Tie::Hash;
75our @ISA = qw(Tie::Hash);
76use strict;
77use Carp ();
78
79BEGIN {
80  local $@;
81  # determine whether we need to take care of threads
82  use Config ();
83  my $usethreads = $Config::Config{usethreads}; # && exists $INC{"threads.pm"}
84  *_HAS_THREADS = $usethreads ? sub () { 1 } : sub () { 0 };
85  *_HAS_SCALAR_UTIL = eval { require Scalar::Util; 1 } ? sub () { 1 } : sub () { 0 };
86  *_HAS_WEAKEN = defined(&Scalar::Util::weaken) ? sub () { 1 } : sub () { 0 };
87}
88
89BEGIN {
90  # create a refaddr function
91
92  local $@;
93
94  if ( _HAS_SCALAR_UTIL ) {
95    *refaddr = sub { goto \&Scalar::Util::refaddr }
96  } else {
97    require overload;
98
99    *refaddr = sub {
100      if ( overload::StrVal($_[0]) =~ /\( 0x ([a-zA-Z0-9]+) \)$/x) {
101          return $1;
102      } else {
103        die "couldn't parse StrVal: " . overload::StrVal($_[0]);
104      }
105    };
106  }
107}
108
109my (@thread_object_registry, $count); # used by the CLONE method to rehash the keys after their refaddr changed
110
111sub TIEHASH {
112  my $c = shift;
113  my $s = [];
114  bless $s, $c;
115  while (@_) {
116    $s->STORE(shift, shift);
117  }
118
119  if (_HAS_THREADS ) {
120
121    if ( _HAS_WEAKEN ) {
122      # remember the object so that we can rekey it on CLONE
123      push @thread_object_registry, $s;
124      # but make this a weak reference, so that there are no leaks
125      Scalar::Util::weaken( $thread_object_registry[-1] );
126
127      if ( ++$count > 1000 ) {
128        # this ensures we don't fill up with a huge array dead weakrefs
129        @thread_object_registry = grep defined, @thread_object_registry;
130        $count = 0;
131      }
132    } else {
133      $count++; # used in the warning
134    }
135  }
136
137  return $s;
138}
139
140my $storable_format_version = join("/", __PACKAGE__, "0.01");
141
142sub STORABLE_freeze {
143  my ( $self, $is_cloning ) = @_;
144  my ( $refs, $reg ) = @$self;
145  return ( $storable_format_version, [ values %$refs ], $reg || {} );
146}
147
148sub STORABLE_thaw {
149  my ( $self, $is_cloning, $version, $refs, $reg ) = @_;
150  Carp::croak "incompatible versions of Tie::RefHash between freeze and thaw"
151    unless $version eq $storable_format_version;
152
153  @$self = ( {}, $reg );
154  $self->_reindex_keys( $refs );
155}
156
157sub CLONE {
158  my $pkg = shift;
159
160  if ( $count and not _HAS_WEAKEN ) {
161    warn "Tie::RefHash is not threadsafe without Scalar::Util::weaken";
162  }
163
164  # when the thread has been cloned all the objects need to be updated.
165  # dead weakrefs are undefined, so we filter them out
166  @thread_object_registry = grep defined && do { $_->_reindex_keys; 1 }, @thread_object_registry;
167  $count = 0; # we just cleaned up
168}
169
170sub _reindex_keys {
171  my ( $self, $extra_keys ) = @_;
172  # rehash all the ref keys based on their new StrVal
173  %{ $self->[0] } = map +(Scalar::Util::refaddr($_->[0]) => $_), (values(%{ $self->[0] }), @{ $extra_keys || [] });
174}
175
176sub FETCH {
177  my($s, $k) = @_;
178  if (ref $k) {
179      my $kstr = Scalar::Util::refaddr($k);
180      if (defined $s->[0]{$kstr}) {
181        $s->[0]{$kstr}[1];
182      }
183      else {
184        undef;
185      }
186  }
187  else {
188      $s->[1]{$k};
189  }
190}
191
192sub STORE {
193  my($s, $k, $v) = @_;
194  if (ref $k) {
195    $s->[0]{Scalar::Util::refaddr($k)} = [$k, $v];
196  }
197  else {
198    $s->[1]{$k} = $v;
199  }
200  $v;
201}
202
203sub DELETE {
204  my($s, $k) = @_;
205  (ref $k)
206    ? (delete($s->[0]{Scalar::Util::refaddr($k)}) || [])->[1]
207    : delete($s->[1]{$k});
208}
209
210sub EXISTS {
211  my($s, $k) = @_;
212  (ref $k) ? exists($s->[0]{Scalar::Util::refaddr($k)}) : exists($s->[1]{$k});
213}
214
215sub FIRSTKEY {
216  my $s = shift;
217  keys %{$s->[0]};  # reset iterator
218  keys %{$s->[1]};  # reset iterator
219  $s->[2] = 0;      # flag for iteration, see NEXTKEY
220  $s->NEXTKEY;
221}
222
223sub NEXTKEY {
224  my $s = shift;
225  my ($k, $v);
226  if (!$s->[2]) {
227    if (($k, $v) = each %{$s->[0]}) {
228      return $v->[0];
229    }
230    else {
231      $s->[2] = 1;
232    }
233  }
234  return each %{$s->[1]};
235}
236
237sub CLEAR {
238  my $s = shift;
239  $s->[2] = 0;
240  %{$s->[0]} = ();
241  %{$s->[1]} = ();
242}
243
244package # hide from PAUSE
245  Tie::RefHash::Nestable;
246our @ISA = 'Tie::RefHash';
247
248sub STORE {
249  my($s, $k, $v) = @_;
250  if (ref($v) eq 'HASH' and not tied %$v) {
251      my @elems = %$v;
252      tie %$v, ref($s), @elems;
253  }
254  $s->SUPER::STORE($k, $v);
255}
256
2571;
258
259__END__
260
261=pod
262
263=encoding UTF-8
264
265=head1 NAME
266
267Tie::RefHash - Use references as hash keys
268
269=head1 VERSION
270
271version 1.40
272
273=head1 SYNOPSIS
274
275    require 5.004;
276    use Tie::RefHash;
277    tie HASHVARIABLE, 'Tie::RefHash', LIST;
278    tie HASHVARIABLE, 'Tie::RefHash::Nestable', LIST;
279
280    untie HASHVARIABLE;
281
282=head1 DESCRIPTION
283
284This module provides the ability to use references as hash keys if you
285first C<tie> the hash variable to this module.  Normally, only the
286keys of the tied hash itself are preserved as references; to use
287references as keys in hashes-of-hashes, use Tie::RefHash::Nestable,
288included as part of Tie::RefHash.
289
290It is implemented using the standard perl TIEHASH interface.  Please
291see the C<tie> entry in perlfunc(1) and perltie(1) for more information.
292
293The Nestable version works by looking for hash references being stored
294and converting them to tied hashes so that they too can have
295references as keys.  This will happen without warning whenever you
296store a reference to one of your own hashes in the tied hash.
297
298=head1 EXAMPLE
299
300    use Tie::RefHash;
301    tie %h, 'Tie::RefHash';
302    $a = [];
303    $b = {};
304    $c = \*main;
305    $d = \"gunk";
306    $e = sub { 'foo' };
307    %h = ($a => 1, $b => 2, $c => 3, $d => 4, $e => 5);
308    $a->[0] = 'foo';
309    $b->{foo} = 'bar';
310    for (keys %h) {
311       print ref($_), "\n";
312    }
313
314    tie %h, 'Tie::RefHash::Nestable';
315    $h{$a}->{$b} = 1;
316    for (keys %h, keys %{$h{$a}}) {
317       print ref($_), "\n";
318    }
319
320=head1 THREAD SUPPORT
321
322L<Tie::RefHash> fully supports threading using the C<CLONE> method.
323
324=head1 STORABLE SUPPORT
325
326L<Storable> hooks are provided for semantically correct serialization and
327cloning of tied refhashes.
328
329=head1 SEE ALSO
330
331perl(1), perlfunc(1), perltie(1)
332
333=head1 SUPPORT
334
335Bugs may be submitted through L<the RT bug tracker|https://rt.cpan.org/Public/Dist/Display.html?Name=Tie-RefHash>
336(or L<bug-Tie-RefHash@rt.cpan.org|mailto:bug-Tie-RefHash@rt.cpan.org>).
337
338=head1 AUTHORS
339
340Gurusamy Sarathy <gsar@activestate.com>
341
342Tie::RefHash::Nestable by Ed Avis <ed@membled.com>
343
344=head1 CONTRIBUTORS
345
346=for stopwords Yuval Kogman Karen Etheridge Florian Ragwitz Jerry D. Hedden
347
348=over 4
349
350=item *
351
352Yuval Kogman <nothingmuch@woobling.org>
353
354=item *
355
356Karen Etheridge <ether@cpan.org>
357
358=item *
359
360Florian Ragwitz <rafl@debian.org>
361
362=item *
363
364Jerry D. Hedden <jdhedden@cpan.org>
365
366=back
367
368=head1 COPYRIGHT AND LICENCE
369
370This software is copyright (c) 2006 by יובל קוג'מן (Yuval Kogman) <nothingmuch@woobling.org>.
371
372This is free software; you can redistribute it and/or modify it under
373the same terms as the Perl 5 programming language system itself.
374
375=cut
376