From: Rafael Garcia-Suarez Date: Fri, 12 May 2006 13:09:29 +0000 (+0000) Subject: Upgrade to Tie::RefHash 1.34, by Yuval Kogman X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=f0f40d8670b7f33d2000added2e7cf136c08f07b;p=p5sagit%2Fp5-mst-13.2.git Upgrade to Tie::RefHash 1.34, by Yuval Kogman p4raw-id: //depot/perl@28177 --- diff --git a/MANIFEST b/MANIFEST index 5f06f81..e6873e3 100644 --- a/MANIFEST +++ b/MANIFEST @@ -2553,6 +2553,8 @@ lib/Tie/Memoize.pm Base class for memoized tied hashes lib/Tie/Memoize.t Test for Memoize.t lib/Tie/RefHash.pm Base class for tied hashes with references as keys lib/Tie/RefHash/refhash.t Test for Tie::RefHash and Tie::RefHash::Nestable +lib/Tie/RefHash/rebless.t Test for Tie::RefHash with rebless +lib/Tie/RefHash/storable.t Test for Tie::RefHash with storable lib/Tie/RefHash/threaded.t Test for Tie::RefHash with threads lib/Tie/Scalar.pm Base class for tied scalars lib/Tie/Scalar.t See if Tie::Scalar works diff --git a/lib/Tie/RefHash.pm b/lib/Tie/RefHash.pm index e2ce01d..30a90d9 100644 --- a/lib/Tie/RefHash.pm +++ b/lib/Tie/RefHash.pm @@ -1,6 +1,8 @@ package Tie::RefHash; -our $VERSION = 1.33; +use vars qw/$VERSION/; + +$VERSION = "1.34"; =head1 NAME @@ -53,6 +55,24 @@ store a reference to one of your own hashes in the tied hash. 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 @@ -69,15 +89,33 @@ use Tie::Hash; use vars '@ISA'; @ISA = qw(Tie::Hash); use strict; +use Carp qw/croak/; BEGIN { + # 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 }; require Scalar::Util if $usethreads; # we need weaken() } -require overload; # to support objects with overloaded "" +BEGIN { + # create a refaddr function + + if ( eval { require Scalar::Util; 1 } ) { + 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 @@ -105,24 +143,41 @@ sub TIEHASH { 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; # 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 { $_->CLONE_OBJ; 1 } } @thread_object_registry; + @thread_object_registry = grep { defined && do { $_->_reindex_keys; 1 } } @thread_object_registry; $count = 0; # we just cleaned up } -sub CLONE_OBJ { - my $self = shift; +sub _reindex_keys { + my ( $self, $extra_keys ) = @_; # rehash all the ref keys based on their new StrVal - %{ $self->[0] } = map { overload::StrVal($_->[0]) => $_ } values %{ $self->[0] }; + %{ $self->[0] } = map { refaddr($_->[0]) => $_ } (values(%{ $self->[0] }), @{ $extra_keys || [] }); } sub FETCH { my($s, $k) = @_; if (ref $k) { - my $kstr = overload::StrVal($k); + my $kstr = refaddr($k); if (defined $s->[0]{$kstr}) { $s->[0]{$kstr}[1]; } @@ -138,7 +193,7 @@ sub FETCH { sub STORE { my($s, $k, $v) = @_; if (ref $k) { - $s->[0]{overload::StrVal($k)} = [$k, $v]; + $s->[0]{refaddr($k)} = [$k, $v]; } else { $s->[1]{$k} = $v; @@ -149,19 +204,19 @@ sub STORE { sub DELETE { my($s, $k) = @_; (ref $k) - ? (delete($s->[0]{overload::StrVal($k)}) || [])->[1] + ? (delete($s->[0]{refaddr($k)}) || [])->[1] : delete($s->[1]{$k}); } sub EXISTS { my($s, $k) = @_; - (ref $k) ? exists($s->[0]{overload::StrVal($k)}) : exists($s->[1]{$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 + keys %{$s->[0]}; # reset iterator + keys %{$s->[1]}; # reset iterator $s->[2] = 0; # flag for iteration, see NEXTKEY $s->NEXTKEY; } diff --git a/lib/Tie/RefHash/rebless.t b/lib/Tie/RefHash/rebless.t new file mode 100644 index 0000000..4ae40f4 --- /dev/null +++ b/lib/Tie/RefHash/rebless.t @@ -0,0 +1,36 @@ +#!/usr/bin/perl -T -w + +BEGIN { + if( $ENV{PERL_CORE} ) { + chdir 't'; + @INC = '../lib'; + } +} + +use strict; + +use Tie::RefHash; + +{ + package Moose; + sub new { bless { }, shift }; + + package Elk; + use vars qw/@ISA/; + @ISA = "Moose"; +} + +$\ = "\n"; +print "1..2"; + +my $obj = Moose->new; + +tie my %hash, "Tie::RefHash"; + +$hash{$obj} = "magic"; + +print ( ( $hash{$obj} eq "magic" ) ? "" : "not ", "ok - keyed before rebless" ); + +bless $obj, "Elk"; + +print ( ( $hash{$obj} eq "magic" ) ? "" : "not ", "ok - still the same"); diff --git a/lib/Tie/RefHash/refhash.t b/lib/Tie/RefHash/refhash.t index 3415cec..d19f7d3 100644 --- a/lib/Tie/RefHash/refhash.t +++ b/lib/Tie/RefHash/refhash.t @@ -1,4 +1,4 @@ -#!/usr/bin/perl -w +#!/usr/bin/perl -T -w # # Basic test suite for Tie::RefHash and Tie::RefHash::Nestable. # @@ -10,14 +10,17 @@ # BEGIN { - chdir 't' if -d 't'; - @INC = '.'; - push @INC, '../lib'; - require Config; - if (($Config::Config{'extensions'} !~ m!\bData/Dumper\b!) ){ - print "1..0 # Skip -- Perl configured without Data::Dumper module\n"; - exit 0; + if( $ENV{PERL_CORE} ) { + chdir 't'; + @INC = '../lib'; } +} + +BEGIN { + unless ( eval { require Data::Dumper; 1 } ) { + print "1..0 # Skip -- Data::Dumper is not available\n"; + exit 0; + } } use strict; @@ -221,7 +224,7 @@ sub runtests { s/ at .+ line \d+\.$//mg; s/ at .+ line \d+, at .*//mg; s/ at .+ line \d+, near .*//mg; - s/(uninitialized value)( within)? [\$@%].*? in /$1 in /g; + s/(uninitialized value)( within)? [\$@%].*? in /$1 in /g; } my (@warnings, %seen); diff --git a/lib/Tie/RefHash/storable.t b/lib/Tie/RefHash/storable.t new file mode 100644 index 0000000..6c28b77 --- /dev/null +++ b/lib/Tie/RefHash/storable.t @@ -0,0 +1,63 @@ +#!/usr/bin/perl -T -w + +BEGIN { + if( $ENV{PERL_CORE} ) { + chdir 't'; + @INC = '../lib'; + } +} + +BEGIN { + unless ( eval { require Storable; 1 } ){ + print "1..0 # Skip -- Storable is not available\n"; + exit 0; + } +} + +use strict; + +use Tie::RefHash; + +use Storable qw/dclone nfreeze thaw/; + +$\ = "\n"; +print "1..24"; + +sub ok ($$) { + print ( ( $_[0] ? "" : "not " ), "ok - $_[1]" ); +} + +sub is ($$$) { + print ( ( ( $_[0] eq $_[1] ) ? "" : "not "), "ok - $_[2]" ); +} + +sub isa_ok ($$) { + ok( eval { $_[0]->isa($_[1]) }, "the object isa $_[1]"); +} + +tie my %hash, "Tie::RefHash"; + +my $key = { foo => 1 }; +$hash{$key} = "value"; +$hash{non_ref} = "other"; + +foreach my $clone ( \%hash, dclone(\%hash), thaw(nfreeze(\%hash)) ){ + + ok( tied(%$clone), "copy is tied"); + isa_ok( tied(%$clone), "Tie::RefHash" ); + + my @keys = keys %$clone; + is( scalar(@keys), 2, "one key in clone"); + my $key = ref($keys[0]) ? shift @keys : pop @keys; + my $reg = $keys[0]; + + ok( ref($key), "key is a ref after clone" ); + is( $key->{foo}, 1, "key serialized ok"); + + is( $clone->{$key}, "value", "and is still pointing at the same value" ); + + ok( !ref($reg), "regular key is non ref" ); + is( $clone->{$reg}, "other", "and is also a valid key" ); +} + + diff --git a/lib/Tie/RefHash/threaded.t b/lib/Tie/RefHash/threaded.t index a2b63e9..d6caed4 100644 --- a/lib/Tie/RefHash/threaded.t +++ b/lib/Tie/RefHash/threaded.t @@ -1,27 +1,37 @@ -#!./perl +#!/usr/bin/perl -T -w BEGIN { - chdir 't' if -d 't'; - @INC = qw(../lib); + if( $ENV{PERL_CORE} ) { + chdir 't'; + @INC = '../lib'; + } } use strict; -use warnings; BEGIN { # this is sucky because threads.pm has to be loaded before Test::Builder - use Config; - if ( $Config{usethreads} ) { - require threads; threads->import; - require Test::More; Test::More->import( tests => 14 ); - } else { - require Test::More; - Test::More->import( skip_all => "threads aren't enabled in your perl" ) - } + use Config; + if ( $Config{usethreads} and !$Config{use5005threads} ) { + require threads; "threads"->import; + print "1..14\n"; + } else { + print "1..0 # Skip -- threads aren't enabled in your perl\n"; + exit 0; + } } use Tie::RefHash; +$\ = "\n"; +sub ok ($$) { + print ( ( $_[0] ? "" : "not " ), "ok - $_[1]" ); +} + +sub is ($$$) { + print ( ( ( $_[0] eq $_[1] ) ? "" : "not "), "ok - $_[2]" ); +} + tie my %hash, "Tie::RefHash"; my $r1 = {}; @@ -37,18 +47,18 @@ is( $hash{$r1}, "hash", "fetch by ref before clone ($r1)" ); is( $hash{$r2}, "array", "fetch by ref before clone ($r2)" ); my $th = threads->create(sub { - is( scalar keys %hash, 3, "key count is OK" ); + is( scalar keys %hash, 3, "key count is OK" ); - ok( exists $hash{$v1}, "string key exists ($v1)" ); - is( $hash{$v1}, "string", "fetch by string" ); + ok( exists $hash{$v1}, "string key exists ($v1)" ); + is( $hash{$v1}, "string", "fetch by string" ); - ok( exists $hash{$r1}, "ref key exists ($r1)" ); - is( $hash{$r1}, "hash", "fetch by ref" ); + ok( exists $hash{$r1}, "ref key exists ($r1)" ); + is( $hash{$r1}, "hash", "fetch by ref" ); - ok( exists $hash{$r2}, "ref key exists ($r2)" ); - is( $hash{$r2}, "array", "fetch by ref" ); + ok( exists $hash{$r2}, "ref key exists ($r2)" ); + is( $hash{$r2}, "array", "fetch by ref" ); - is_deeply( [ sort keys %hash ], [ sort $r1, $r2, $v1 ], "keys are ok" ); + is( join("\0",sort keys %hash), join("\0",sort $r1, $r2, $v1), "keys are ok" ); }); $th->join;