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
package Tie::RefHash;
-our $VERSION = 1.33;
+use vars qw/$VERSION/;
+
+$VERSION = "1.34";
=head1 NAME
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 MAINTAINER
+
+Yuval Kogman E<lt>nothingmuch@woobling.orgE<gt>
+
=head1 AUTHOR
Gurusamy Sarathy gsar@activestate.com
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
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];
}
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;
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;
}
--- /dev/null
+#!/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");
-#!/usr/bin/perl -w
+#!/usr/bin/perl -T -w
#
# Basic test suite for Tie::RefHash and Tie::RefHash::Nestable.
#
#
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;
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);
--- /dev/null
+#!/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" );
+}
+
+
-#!./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 = {};
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;
projects / p5sagit/p5-mst-13.2.git / commitdiff