lib/Tie/RefHash.pm

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