lib/Tie/RefHash.pm

   1 package Tie::RefHash;
   2
   3 our $VERSION = 1.33;
   4
   5 =head1 NAME
   6
   7 Tie::RefHash - use references as hash keys
   8
   9 =head1 SYNOPSIS
  10
  11     require 5.004;
  12     use Tie::RefHash;
  13     tie HASHVARIABLE, 'Tie::RefHash', LIST;
  14     tie HASHVARIABLE, 'Tie::RefHash::Nestable', LIST;
  15
  16     untie HASHVARIABLE;
  17
  18 =head1 DESCRIPTION
  19
  20 This module provides the ability to use references as hash keys if you
  21 first C<tie> the hash variable to this module.  Normally, only the
  22 keys of the tied hash itself are preserved as references; to use
  23 references as keys in hashes-of-hashes, use Tie::RefHash::Nestable,
  24 included as part of Tie::RefHash.
  25
  26 It is implemented using the standard perl TIEHASH interface.  Please
  27 see the C<tie> entry in perlfunc(1) and perltie(1) for more information.
  28
  29 The Nestable version works by looking for hash references being stored
  30 and converting them to tied hashes so that they too can have
  31 references as keys.  This will happen without warning whenever you
  32 store a reference to one of your own hashes in the tied hash.
  33
  34 =head1 EXAMPLE
  35
  36     use Tie::RefHash;
  37     tie %h, 'Tie::RefHash';
  38     $a = [];
  39     $b = {};
  40     $c = \*main;
  41     $d = \"gunk";
  42     $e = sub { 'foo' };
  43     %h = ($a => 1, $b => 2, $c => 3, $d => 4, $e => 5);
  44     $a->[0] = 'foo';
  45     $b->{foo} = 'bar';
  46     for (keys %h) {
  47        print ref($_), "\n";
  48     }
  49
  50     tie %h, 'Tie::RefHash::Nestable';
  51     $h{$a}->{$b} = 1;
  52     for (keys %h, keys %{$h{$a}}) {
  53        print ref($_), "\n";
  54     }
  55
  56 =head1 AUTHOR
  57
  58 Gurusamy Sarathy        gsar@activestate.com
  59
  60 'Nestable' by Ed Avis   ed@membled.com
  61
  62 =head1 SEE ALSO
  63
  64 perl(1), perlfunc(1), perltie(1)
  65
  66 =cut
  67
  68 use Tie::Hash;
  69 use vars '@ISA';
  70 @ISA = qw(Tie::Hash);
  71 use strict;
  72
  73 BEGIN {
  74   use Config ();
  75   my $usethreads = $Config::Config{usethreads}; # && exists $INC{"threads.pm"}
  76   *_HAS_THREADS = $usethreads ? sub () { 1 } : sub () { 0 };
  77   require Scalar::Util if $usethreads; # we need weaken()
  78 }
  79
  80 require overload; # to support objects with overloaded ""
  81
  82 my (@thread_object_registry, $count); # used by the CLONE method to rehash the keys after their refaddr changed
  83
  84 sub TIEHASH {
  85   my $c = shift;
  86   my $s = [];
  87   bless $s, $c;
  88   while (@_) {
  89     $s->STORE(shift, shift);
  90   }
  91
  92   if (_HAS_THREADS) {
  93     # remember the object so that we can rekey it on CLONE
  94     push @thread_object_registry, $s;
  95     # but make this a weak reference, so that there are no leaks
  96     Scalar::Util::weaken( $thread_object_registry[-1] );
  97
  98     if ( ++$count > 1000 ) {
  99       # this ensures we don't fill up with a huge array dead weakrefs
 100       @thread_object_registry = grep { defined } @thread_object_registry;
 101       $count = 0;
 102     }
 103   }
 104
 105   return $s;
 106 }
 107
 108 sub CLONE {
 109   my $pkg = shift;
 110   # when the thread has been cloned all the objects need to be updated.
 111   # dead weakrefs are undefined, so we filter them out
 112   @thread_object_registry = grep { defined && do { $_->CLONE_OBJ; 1 } } @thread_object_registry;
 113   $count = 0; # we just cleaned up
 114 }
 115
 116 sub CLONE_OBJ {
 117   my $self = shift;
 118   # rehash all the ref keys based on their new StrVal
 119   %{ $self->[0] } = map { overload::StrVal($_->[0]) => $_ } values %{ $self->[0] };
 120 }
 121
 122 sub FETCH {
 123   my($s, $k) = @_;
 124   if (ref $k) {
 125       my $kstr = overload::StrVal($k);
 126       if (defined $s->[0]{$kstr}) {
 127         $s->[0]{$kstr}[1];
 128       }
 129       else {
 130         undef;
 131       }
 132   }
 133   else {
 134       $s->[1]{$k};
 135   }
 136 }
 137
 138 sub STORE {
 139   my($s, $k, $v) = @_;
 140   if (ref $k) {
 141     $s->[0]{overload::StrVal($k)} = [$k, $v];
 142   }
 143   else {
 144     $s->[1]{$k} = $v;
 145   }
 146   $v;
 147 }
 148
 149 sub DELETE {
 150   my($s, $k) = @_;
 151   (ref $k)
 152     ? (delete($s->[0]{overload::StrVal($k)}) || [])->[1]
 153     : delete($s->[1]{$k});
 154 }
 155
 156 sub EXISTS {
 157   my($s, $k) = @_;
 158   (ref $k) ? exists($s->[0]{overload::StrVal($k)}) : exists($s->[1]{$k});
 159 }
 160
 161 sub FIRSTKEY {
 162   my $s = shift;
 163   keys %{$s->[0]};      # reset iterator
 164   keys %{$s->[1]};      # reset iterator
 165   $s->[2] = 0;      # flag for iteration, see NEXTKEY
 166   $s->NEXTKEY;
 167 }
 168
 169 sub NEXTKEY {
 170   my $s = shift;
 171   my ($k, $v);
 172   if (!$s->[2]) {
 173     if (($k, $v) = each %{$s->[0]}) {
 174       return $v->[0];
 175     }
 176     else {
 177       $s->[2] = 1;
 178     }
 179   }
 180   return each %{$s->[1]};
 181 }
 182
 183 sub CLEAR {
 184   my $s = shift;
 185   $s->[2] = 0;
 186   %{$s->[0]} = ();
 187   %{$s->[1]} = ();
 188 }
 189
 190 package Tie::RefHash::Nestable;
 191 use vars '@ISA';
 192 @ISA = 'Tie::RefHash';
 193
 194 sub STORE {
 195   my($s, $k, $v) = @_;
 196   if (ref($v) eq 'HASH' and not tied %$v) {
 197       my @elems = %$v;
 198       tie %$v, ref($s), @elems;
 199   }
 200   $s->SUPER::STORE($k, $v);
 201 }
 202
 203 1;