280 lines
6.1 KiB
Perl
280 lines
6.1 KiB
Perl
|
package Tie::RefHash;
|
||
|
|
||
|
use vars qw/$VERSION/;
|
||
|
|
||
|
$VERSION = "1.39";
|
||
|
|
||
|
use 5.005;
|
||
|
|
||
|
=head1 NAME
|
||
|
|
||
|
Tie::RefHash - use references as hash keys
|
||
|
|
||
|
=head1 SYNOPSIS
|
||
|
|
||
|
require 5.004;
|
||
|
use Tie::RefHash;
|
||
|
tie HASHVARIABLE, 'Tie::RefHash', LIST;
|
||
|
tie HASHVARIABLE, 'Tie::RefHash::Nestable', LIST;
|
||
|
|
||
|
untie HASHVARIABLE;
|
||
|
|
||
|
=head1 DESCRIPTION
|
||
|
|
||
|
This module provides the ability to use references as hash keys if you
|
||
|
first C<tie> the hash variable to this module. Normally, only the
|
||
|
keys of the tied hash itself are preserved as references; to use
|
||
|
references as keys in hashes-of-hashes, use Tie::RefHash::Nestable,
|
||
|
included as part of Tie::RefHash.
|
||
|
|
||
|
It is implemented using the standard perl TIEHASH interface. Please
|
||
|
see the C<tie> entry in perlfunc(1) and perltie(1) for more information.
|
||
|
|
||
|
The Nestable version works by looking for hash references being stored
|
||
|
and converting them to tied hashes so that they too can have
|
||
|
references as keys. This will happen without warning whenever you
|
||
|
store a reference to one of your own hashes in the tied hash.
|
||
|
|
||
|
=head1 EXAMPLE
|
||
|
|
||
|
use Tie::RefHash;
|
||
|
tie %h, 'Tie::RefHash';
|
||
|
$a = [];
|
||
|
$b = {};
|
||
|
$c = \*main;
|
||
|
$d = \"gunk";
|
||
|
$e = sub { 'foo' };
|
||
|
%h = ($a => 1, $b => 2, $c => 3, $d => 4, $e => 5);
|
||
|
$a->[0] = 'foo';
|
||
|
$b->{foo} = 'bar';
|
||
|
for (keys %h) {
|
||
|
print ref($_), "\n";
|
||
|
}
|
||
|
|
||
|
tie %h, 'Tie::RefHash::Nestable';
|
||
|
$h{$a}->{$b} = 1;
|
||
|
for (keys %h, keys %{$h{$a}}) {
|
||
|
print ref($_), "\n";
|
||
|
}
|
||
|
|
||
|
=head1 THREAD SUPPORT
|
||
|
|
||
|
L<Tie::RefHash> fully supports threading using the C<CLONE> method.
|
||
|
|
||
|
=head1 STORABLE SUPPORT
|
||
|
|
||
|
L<Storable> hooks are provided for semantically correct serialization and
|
||
|
cloning of tied refhashes.
|
||
|
|
||
|
=head1 RELIC SUPPORT
|
||
|
|
||
|
This version of Tie::RefHash seems to no longer work with 5.004. This has not
|
||
|
been throughly investigated. Patches welcome ;-)
|
||
|
|
||
|
=head1 LICENSE
|
||
|
|
||
|
This program is free software; you can redistribute it and/or modify it under
|
||
|
the same terms as Perl itself
|
||
|
|
||
|
=head1 MAINTAINER
|
||
|
|
||
|
Yuval Kogman E<lt>nothingmuch@woobling.orgE<gt>
|
||
|
|
||
|
=head1 AUTHOR
|
||
|
|
||
|
Gurusamy Sarathy gsar@activestate.com
|
||
|
|
||
|
'Nestable' by Ed Avis ed@membled.com
|
||
|
|
||
|
=head1 SEE ALSO
|
||
|
|
||
|
perl(1), perlfunc(1), perltie(1)
|
||
|
|
||
|
=cut
|
||
|
|
||
|
use Tie::Hash;
|
||
|
use vars '@ISA';
|
||
|
@ISA = qw(Tie::Hash);
|
||
|
use strict;
|
||
|
use Carp qw/croak/;
|
||
|
|
||
|
BEGIN {
|
||
|
local $@;
|
||
|
# determine whether we need to take care of threads
|
||
|
use Config ();
|
||
|
my $usethreads = $Config::Config{usethreads}; # && exists $INC{"threads.pm"}
|
||
|
*_HAS_THREADS = $usethreads ? sub () { 1 } : sub () { 0 };
|
||
|
*_HAS_SCALAR_UTIL = eval { require Scalar::Util; 1 } ? sub () { 1 } : sub () { 0 };
|
||
|
*_HAS_WEAKEN = defined(&Scalar::Util::weaken) ? sub () { 1 } : sub () { 0 };
|
||
|
}
|
||
|
|
||
|
BEGIN {
|
||
|
# create a refaddr function
|
||
|
|
||
|
local $@;
|
||
|
|
||
|
if ( _HAS_SCALAR_UTIL ) {
|
||
|
Scalar::Util->import("refaddr");
|
||
|
} else {
|
||
|
require overload;
|
||
|
|
||
|
*refaddr = sub {
|
||
|
if ( overload::StrVal($_[0]) =~ /\( 0x ([a-zA-Z0-9]+) \)$/x) {
|
||
|
return $1;
|
||
|
} else {
|
||
|
die "couldn't parse StrVal: " . overload::StrVal($_[0]);
|
||
|
}
|
||
|
};
|
||
|
}
|
||
|
}
|
||
|
|
||
|
my (@thread_object_registry, $count); # used by the CLONE method to rehash the keys after their refaddr changed
|
||
|
|
||
|
sub TIEHASH {
|
||
|
my $c = shift;
|
||
|
my $s = [];
|
||
|
bless $s, $c;
|
||
|
while (@_) {
|
||
|
$s->STORE(shift, shift);
|
||
|
}
|
||
|
|
||
|
if (_HAS_THREADS ) {
|
||
|
|
||
|
if ( _HAS_WEAKEN ) {
|
||
|
# remember the object so that we can rekey it on CLONE
|
||
|
push @thread_object_registry, $s;
|
||
|
# but make this a weak reference, so that there are no leaks
|
||
|
Scalar::Util::weaken( $thread_object_registry[-1] );
|
||
|
|
||
|
if ( ++$count > 1000 ) {
|
||
|
# this ensures we don't fill up with a huge array dead weakrefs
|
||
|
@thread_object_registry = grep { defined } @thread_object_registry;
|
||
|
$count = 0;
|
||
|
}
|
||
|
} else {
|
||
|
$count++; # used in the warning
|
||
|
}
|
||
|
}
|
||
|
|
||
|
return $s;
|
||
|
}
|
||
|
|
||
|
my $storable_format_version = join("/", __PACKAGE__, "0.01");
|
||
|
|
||
|
sub STORABLE_freeze {
|
||
|
my ( $self, $is_cloning ) = @_;
|
||
|
my ( $refs, $reg ) = @$self;
|
||
|
return ( $storable_format_version, [ values %$refs ], $reg || {} );
|
||
|
}
|
||
|
|
||
|
sub STORABLE_thaw {
|
||
|
my ( $self, $is_cloning, $version, $refs, $reg ) = @_;
|
||
|
croak "incompatible versions of Tie::RefHash between freeze and thaw"
|
||
|
unless $version eq $storable_format_version;
|
||
|
|
||
|
@$self = ( {}, $reg );
|
||
|
$self->_reindex_keys( $refs );
|
||
|
}
|
||
|
|
||
|
sub CLONE {
|
||
|
my $pkg = shift;
|
||
|
|
||
|
if ( $count and not _HAS_WEAKEN ) {
|
||
|
warn "Tie::RefHash is not threadsafe without Scalar::Util::weaken";
|
||
|
}
|
||
|
|
||
|
# when the thread has been cloned all the objects need to be updated.
|
||
|
# dead weakrefs are undefined, so we filter them out
|
||
|
@thread_object_registry = grep { defined && do { $_->_reindex_keys; 1 } } @thread_object_registry;
|
||
|
$count = 0; # we just cleaned up
|
||
|
}
|
||
|
|
||
|
sub _reindex_keys {
|
||
|
my ( $self, $extra_keys ) = @_;
|
||
|
# rehash all the ref keys based on their new StrVal
|
||
|
%{ $self->[0] } = map { refaddr($_->[0]) => $_ } (values(%{ $self->[0] }), @{ $extra_keys || [] });
|
||
|
}
|
||
|
|
||
|
sub FETCH {
|
||
|
my($s, $k) = @_;
|
||
|
if (ref $k) {
|
||
|
my $kstr = refaddr($k);
|
||
|
if (defined $s->[0]{$kstr}) {
|
||
|
$s->[0]{$kstr}[1];
|
||
|
}
|
||
|
else {
|
||
|
undef;
|
||
|
}
|
||
|
}
|
||
|
else {
|
||
|
$s->[1]{$k};
|
||
|
}
|
||
|
}
|
||
|
|
||
|
sub STORE {
|
||
|
my($s, $k, $v) = @_;
|
||
|
if (ref $k) {
|
||
|
$s->[0]{refaddr($k)} = [$k, $v];
|
||
|
}
|
||
|
else {
|
||
|
$s->[1]{$k} = $v;
|
||
|
}
|
||
|
$v;
|
||
|
}
|
||
|
|
||
|
sub DELETE {
|
||
|
my($s, $k) = @_;
|
||
|
(ref $k)
|
||
|
? (delete($s->[0]{refaddr($k)}) || [])->[1]
|
||
|
: delete($s->[1]{$k});
|
||
|
}
|
||
|
|
||
|
sub EXISTS {
|
||
|
my($s, $k) = @_;
|
||
|
(ref $k) ? exists($s->[0]{refaddr($k)}) : exists($s->[1]{$k});
|
||
|
}
|
||
|
|
||
|
sub FIRSTKEY {
|
||
|
my $s = shift;
|
||
|
keys %{$s->[0]}; # reset iterator
|
||
|
keys %{$s->[1]}; # reset iterator
|
||
|
$s->[2] = 0; # flag for iteration, see NEXTKEY
|
||
|
$s->NEXTKEY;
|
||
|
}
|
||
|
|
||
|
sub NEXTKEY {
|
||
|
my $s = shift;
|
||
|
my ($k, $v);
|
||
|
if (!$s->[2]) {
|
||
|
if (($k, $v) = each %{$s->[0]}) {
|
||
|
return $v->[0];
|
||
|
}
|
||
|
else {
|
||
|
$s->[2] = 1;
|
||
|
}
|
||
|
}
|
||
|
return each %{$s->[1]};
|
||
|
}
|
||
|
|
||
|
sub CLEAR {
|
||
|
my $s = shift;
|
||
|
$s->[2] = 0;
|
||
|
%{$s->[0]} = ();
|
||
|
%{$s->[1]} = ();
|
||
|
}
|
||
|
|
||
|
package Tie::RefHash::Nestable;
|
||
|
use vars '@ISA';
|
||
|
@ISA = 'Tie::RefHash';
|
||
|
|
||
|
sub STORE {
|
||
|
my($s, $k, $v) = @_;
|
||
|
if (ref($v) eq 'HASH' and not tied %$v) {
|
||
|
my @elems = %$v;
|
||
|
tie %$v, ref($s), @elems;
|
||
|
}
|
||
|
$s->SUPER::STORE($k, $v);
|
||
|
}
|
||
|
|
||
|
1;
|