lib/Tie/RefHash.pm

   1 package Tie::RefHash;
   2
   3 use vars qw/$VERSION/;
   4
   5 $VERSION = "1.34_01";
   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   if ($usethreads) {
 100     # The magic of taint tunneling means that we can't do this require in the
 101     # same statement as the boolean check on $usethreads, as $usethreads is
 102     # tainted.
 103     require Scalar::Util;
 104   }
 105 }
 106
 107 BEGIN {
 108   # create a refaddr function
 109
 110   if ( eval { require Scalar::Util; 1 } ) {
 111     Scalar::Util->import("refaddr");
 112   } else {
 113     require overload;
 114
 115     *refaddr = sub {
 116       if ( overload::StrVal($_[0]) =~ /\( 0x ([a-zA-Z0-9]+) \)$/x) {
 117           return $1;
 118       } else {
 119         die "couldn't parse StrVal: " . overload::StrVal($_[0]);
 120       }
 121     };
 122   }
 123 }
 124
 125 my (@thread_object_registry, $count); # used by the CLONE method to rehash the keys after their refaddr changed
 126
 127 sub TIEHASH {
 128   my $c = shift;
 129   my $s = [];
 130   bless $s, $c;
 131   while (@_) {
 132     $s->STORE(shift, shift);
 133   }
 134
 135   if (_HAS_THREADS) {
 136     # remember the object so that we can rekey it on CLONE
 137     push @thread_object_registry, $s;
 138     # but make this a weak reference, so that there are no leaks
 139     Scalar::Util::weaken( $thread_object_registry[-1] );
 140
 141     if ( ++$count > 1000 ) {
 142       # this ensures we don't fill up with a huge array dead weakrefs
 143       @thread_object_registry = grep { defined } @thread_object_registry;
 144       $count = 0;
 145     }
 146   }
 147
 148   return $s;
 149 }
 150
 151 my $storable_format_version = join("/", __PACKAGE__, "0.01");
 152
 153 sub STORABLE_freeze {
 154   my ( $self, $is_cloning ) = @_;
 155   my ( $refs, $reg ) = @$self;
 156   return ( $storable_format_version, [ values %$refs ], $reg );
 157 }
 158
 159 sub STORABLE_thaw {
 160   my ( $self, $is_cloning, $version, $refs, $reg ) = @_;
 161   croak "incompatible versions of Tie::RefHash between freeze and thaw"
 162     unless $version eq $storable_format_version;
 163
 164   @$self = ( {}, $reg );
 165   $self->_reindex_keys( $refs );
 166 }
 167
 168 sub CLONE {
 169   my $pkg = shift;
 170   # when the thread has been cloned all the objects need to be updated.
 171   # dead weakrefs are undefined, so we filter them out
 172   @thread_object_registry = grep { defined && do { $_->_reindex_keys; 1 } } @thread_object_registry;
 173   $count = 0; # we just cleaned up
 174 }
 175
 176 sub _reindex_keys {
 177   my ( $self, $extra_keys ) = @_;
 178   # rehash all the ref keys based on their new StrVal
 179   %{ $self->[0] } = map { refaddr($_->[0]) => $_ } (values(%{ $self->[0] }), @{ $extra_keys || [] });
 180 }
 181
 182 sub FETCH {
 183   my($s, $k) = @_;
 184   if (ref $k) {
 185       my $kstr = refaddr($k);
 186       if (defined $s->[0]{$kstr}) {
 187         $s->[0]{$kstr}[1];
 188       }
 189       else {
 190         undef;
 191       }
 192   }
 193   else {
 194       $s->[1]{$k};
 195   }
 196 }
 197
 198 sub STORE {
 199   my($s, $k, $v) = @_;
 200   if (ref $k) {
 201     $s->[0]{refaddr($k)} = [$k, $v];
 202   }
 203   else {
 204     $s->[1]{$k} = $v;
 205   }
 206   $v;
 207 }
 208
 209 sub DELETE {
 210   my($s, $k) = @_;
 211   (ref $k)
 212     ? (delete($s->[0]{refaddr($k)}) || [])->[1]
 213     : delete($s->[1]{$k});
 214 }
 215
 216 sub EXISTS {
 217   my($s, $k) = @_;
 218   (ref $k) ? exists($s->[0]{refaddr($k)}) : exists($s->[1]{$k});
 219 }
 220
 221 sub FIRSTKEY {
 222   my $s = shift;
 223   keys %{$s->[0]};  # reset iterator
 224   keys %{$s->[1]};  # reset iterator
 225   $s->[2] = 0;      # flag for iteration, see NEXTKEY
 226   $s->NEXTKEY;
 227 }
 228
 229 sub NEXTKEY {
 230   my $s = shift;
 231   my ($k, $v);
 232   if (!$s->[2]) {
 233     if (($k, $v) = each %{$s->[0]}) {
 234       return $v->[0];
 235     }
 236     else {
 237       $s->[2] = 1;
 238     }
 239   }
 240   return each %{$s->[1]};
 241 }
 242
 243 sub CLEAR {
 244   my $s = shift;
 245   $s->[2] = 0;
 246   %{$s->[0]} = ();
 247   %{$s->[1]} = ();
 248 }
 249
 250 package Tie::RefHash::Nestable;
 251 use vars '@ISA';
 252 @ISA = 'Tie::RefHash';
 253
 254 sub STORE {
 255   my($s, $k, $v) = @_;
 256   if (ref($v) eq 'HASH' and not tied %$v) {
 257       my @elems = %$v;
 258       tie %$v, ref($s), @elems;
 259   }
 260   $s->SUPER::STORE($k, $v);
 261 }
 262
 263 1;