local-lib5/lib/perl5/Tie/RefHash.pm

   1 package Tie::RefHash;
   2
   3 use vars qw/$VERSION/;
   4
   5 $VERSION = "1.38";
   6
   7 use 5.005;
   8
   9 =head1 NAME
  10
  11 Tie::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
  24 This module provides the ability to use references as hash keys if you
  25 first C<tie> the hash variable to this module.  Normally, only the
  26 keys of the tied hash itself are preserved as references; to use
  27 references as keys in hashes-of-hashes, use Tie::RefHash::Nestable,
  28 included as part of Tie::RefHash.
  29
  30 It is implemented using the standard perl TIEHASH interface.  Please
  31 see the C<tie> entry in perlfunc(1) and perltie(1) for more information.
  32
  33 The Nestable version works by looking for hash references being stored
  34 and converting them to tied hashes so that they too can have
  35 references as keys.  This will happen without warning whenever you
  36 store 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
  62 L<Tie::RefHash> fully supports threading using the C<CLONE> method.
  63
  64 =head1 STORABLE SUPPORT
  65
  66 L<Storable> hooks are provided for semantically correct serialization and
  67 cloning of tied refhashes.
  68
  69 =head1 RELIC SUPPORT
  70
  71 This version of Tie::RefHash seems to no longer work with 5.004. This has not
  72 been throughly investigated. Patches welcome ;-)
  73
  74 =head1 MAINTAINER
  75
  76 Yuval Kogman E<lt>nothingmuch@woobling.orgE<gt>
  77
  78 =head1 AUTHOR
  79
  80 Gurusamy Sarathy        gsar@activestate.com
  81
  82 'Nestable' by Ed Avis   ed@membled.com
  83
  84 =head1 SEE ALSO
  85
  86 perl(1), perlfunc(1), perltie(1)
  87
  88 =cut
  89
  90 use Tie::Hash;
  91 use vars '@ISA';
  92 @ISA = qw(Tie::Hash);
  93 use strict;
  94 use Carp qw/croak/;
  95
  96 BEGIN {
  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
 106 BEGIN {
 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
 126 my (@thread_object_registry, $count); # used by the CLONE method to rehash the keys after their refaddr changed
 127
 128 sub 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
 157 my $storable_format_version = join("/", __PACKAGE__, "0.01");
 158
 159 sub STORABLE_freeze {
 160   my ( $self, $is_cloning ) = @_;
 161   my ( $refs, $reg ) = @$self;
 162   return ( $storable_format_version, [ values %$refs ], $reg );
 163 }
 164
 165 sub 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
 174 sub 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
 187 sub _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
 193 sub 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
 209 sub 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
 220 sub DELETE {
 221   my($s, $k) = @_;
 222   (ref $k)
 223     ? (delete($s->[0]{refaddr($k)}) || [])->[1]
 224     : delete($s->[1]{$k});
 225 }
 226
 227 sub EXISTS {
 228   my($s, $k) = @_;
 229   (ref $k) ? exists($s->[0]{refaddr($k)}) : exists($s->[1]{$k});
 230 }
 231
 232 sub 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
 240 sub 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
 254 sub CLEAR {
 255   my $s = shift;
 256   $s->[2] = 0;
 257   %{$s->[0]} = ();
 258   %{$s->[1]} = ();
 259 }
 260
 261 package Tie::RefHash::Nestable;
 262 use vars '@ISA';
 263 @ISA = 'Tie::RefHash';
 264
 265 sub 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
 274 1;