X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FTie%2FRefHash.pm;h=f95bf41efdfbdbb104a9e9ef6c38319d950901a0;hb=0508fb16c6a57ba6d246b3ddb11c79c68d302f62;hp=20f0d58bcc09ab735eb5be1319a82d6c6ecc95ed;hpb=9a079709134ebbf4c935cc8752fdb564e5c82b94;p=p5sagit%2Fp5-mst-13.2.git diff --git a/lib/Tie/RefHash.pm b/lib/Tie/RefHash.pm index 20f0d58..f95bf41 100644 --- a/lib/Tie/RefHash.pm +++ b/lib/Tie/RefHash.pm @@ -1,14 +1,129 @@ -# -# Tie/RefHash.pm - use references as hash keys -# -# Documentation at the __END__ -# - -require 5.004; package Tie::RefHash; + +use vars qw/$VERSION/; + +$VERSION = "1.38"; + +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 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 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 fully supports threading using the C method. + +=head1 STORABLE SUPPORT + +L 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 MAINTAINER + +Yuval Kogman Enothingmuch@woobling.orgE + +=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; @@ -17,18 +132,84 @@ sub TIEHASH { 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) = @_; - (ref $k) ? $s->[0]{"$k"}[1] : $s->[1]{$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]{"$k"} = [$k, $v]; + $s->[0]{refaddr($k)} = [$k, $v]; } else { $s->[1]{$k} = $v; @@ -38,18 +219,21 @@ sub STORE { sub DELETE { my($s, $k) = @_; - (ref $k) ? delete($s->[0]{"$k"}) : delete($s->[1]{$k}); + (ref $k) + ? (delete($s->[0]{refaddr($k)}) || [])->[1] + : delete($s->[1]{$k}); } sub EXISTS { my($s, $k) = @_; - (ref $k) ? exists($s->[0]{"$k"}) : exists($s->[1]{$k}); + (ref $k) ? exists($s->[0]{refaddr($k)}) : exists($s->[1]{$k}); } sub FIRSTKEY { my $s = shift; - my $a = scalar(keys %{$s->[0]}) + scalar(keys %{$s->[1]}); - $s->[2] = 0; + keys %{$s->[0]}; # reset iterator + keys %{$s->[1]}; # reset iterator + $s->[2] = 0; # flag for iteration, see NEXTKEY $s->NEXTKEY; } @@ -58,7 +242,7 @@ sub NEXTKEY { my ($k, $v); if (!$s->[2]) { if (($k, $v) = each %{$s->[0]}) { - return $s->[0]{"$k"}[0]; + return $v->[0]; } else { $s->[2] = 1; @@ -74,63 +258,17 @@ sub CLEAR { %{$s->[1]} = (); } -1; - -__END__ - -=head1 NAME - -Tie::RefHash - use references as hash keys - - -=head1 SYNOPSIS - - require 5.004; - use Tie::RefHash; - tie HASHVARIABLE, 'Tie::RefHash', LIST; - - untie HASHVARIABLE; - - -=head1 DESCRIPTION - -This module provides the ability to use references as hash keys if -you first C the hash variable to this module. - -It is implemented using the standard perl TIEHASH interface. Please -see the C entry in perlfunc(1) and perltie(1) for more information. - - -=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"; - } - - -=head1 AUTHOR - -Gurusamy Sarathy gsar@umich.edu - - -=head1 VERSION - -Version 1.2 15 Dec 1996 - - -=head1 SEE ALSO - -perl(1), perlfunc(1), perltie(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); +} -=cut +1;