[Summary view] [Print] [Text view]

   1  package Tie::RefHash;
   2  
   3  use vars qw/$VERSION/;
   4  
   5  $VERSION = "1.37";
   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;