r37107 - in /branches/upstream/libhash-util-fieldhash-compat-perl: ./ current/ current/lib/ current/lib/Hash/ current/lib/Hash/Util/ current/lib/Hash/Util/FieldHash/ current/lib/Hash/Util/FieldHash/Compat/ current/t/

franck-guest at users.alioth.debian.org franck-guest at users.alioth.debian.org
Mon Jun 1 08:44:14 UTC 2009


Author: franck-guest
Date: Mon Jun  1 08:44:09 2009
New Revision: 37107

URL: http://svn.debian.org/wsvn/pkg-perl/?sc=1&rev=37107
Log:
[svn-inject] Installing original source of libhash-util-fieldhash-compat-perl

Added:
    branches/upstream/libhash-util-fieldhash-compat-perl/
    branches/upstream/libhash-util-fieldhash-compat-perl/current/
    branches/upstream/libhash-util-fieldhash-compat-perl/current/MANIFEST
    branches/upstream/libhash-util-fieldhash-compat-perl/current/MANIFEST.SKIP
    branches/upstream/libhash-util-fieldhash-compat-perl/current/META.yml
    branches/upstream/libhash-util-fieldhash-compat-perl/current/Makefile.PL
    branches/upstream/libhash-util-fieldhash-compat-perl/current/SIGNATURE
    branches/upstream/libhash-util-fieldhash-compat-perl/current/lib/
    branches/upstream/libhash-util-fieldhash-compat-perl/current/lib/Hash/
    branches/upstream/libhash-util-fieldhash-compat-perl/current/lib/Hash/Util/
    branches/upstream/libhash-util-fieldhash-compat-perl/current/lib/Hash/Util/FieldHash/
    branches/upstream/libhash-util-fieldhash-compat-perl/current/lib/Hash/Util/FieldHash/Compat/
    branches/upstream/libhash-util-fieldhash-compat-perl/current/lib/Hash/Util/FieldHash/Compat.pm
    branches/upstream/libhash-util-fieldhash-compat-perl/current/lib/Hash/Util/FieldHash/Compat/Heavy.pm
    branches/upstream/libhash-util-fieldhash-compat-perl/current/t/
    branches/upstream/libhash-util-fieldhash-compat-perl/current/t/01_basic.t

Added: branches/upstream/libhash-util-fieldhash-compat-perl/current/MANIFEST
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libhash-util-fieldhash-compat-perl/current/MANIFEST?rev=37107&op=file
==============================================================================
--- branches/upstream/libhash-util-fieldhash-compat-perl/current/MANIFEST (added)
+++ branches/upstream/libhash-util-fieldhash-compat-perl/current/MANIFEST Mon Jun  1 08:44:09 2009
@@ -1,0 +1,8 @@
+lib/Hash/Util/FieldHash/Compat.pm
+lib/Hash/Util/FieldHash/Compat/Heavy.pm
+Makefile.PL
+MANIFEST			This list of files
+MANIFEST.SKIP
+t/01_basic.t
+META.yml                                 Module meta-data (added by MakeMaker)
+SIGNATURE                                Public-key signature (added by MakeMaker)

Added: branches/upstream/libhash-util-fieldhash-compat-perl/current/MANIFEST.SKIP
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libhash-util-fieldhash-compat-perl/current/MANIFEST.SKIP?rev=37107&op=file
==============================================================================
--- branches/upstream/libhash-util-fieldhash-compat-perl/current/MANIFEST.SKIP (added)
+++ branches/upstream/libhash-util-fieldhash-compat-perl/current/MANIFEST.SKIP Mon Jun  1 08:44:09 2009
@@ -1,0 +1,38 @@
+# Avoid version control files.
+\bRCS\b
+\bCVS\b
+\bSCCS\b
+,v$
+\B\.svn\b
+\b_darcs\b
+
+# Avoid Makemaker generated and utility files.
+\bMANIFEST\.bak
+\bMakefile$
+\bblib/
+\bMakeMaker-\d
+\bpm_to_blib\.ts$
+\bpm_to_blib$
+\bblibdirs\.ts$         # 6.18 through 6.25 generated this
+
+# Avoid Module::Build generated and utility files.
+\bBuild$
+\b_build/
+
+# Avoid temp and backup files.
+~$
+\.old$
+\#$
+\b\.#
+\.bak$
+
+# Avoid Devel::Cover files.
+\bcover_db\b
+
+### DEFAULT MANIFEST.SKIP ENDS HERE ####
+
+\.DS_Store$
+\.sw.$
+\.tar\.gz$
+^(\w+-)*(\w+)-\d\.\d+$
+

Added: branches/upstream/libhash-util-fieldhash-compat-perl/current/META.yml
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libhash-util-fieldhash-compat-perl/current/META.yml?rev=37107&op=file
==============================================================================
--- branches/upstream/libhash-util-fieldhash-compat-perl/current/META.yml (added)
+++ branches/upstream/libhash-util-fieldhash-compat-perl/current/META.yml Mon Jun  1 08:44:09 2009
@@ -1,0 +1,13 @@
+--- #YAML:1.0
+name:                Hash-Util-FieldHash-Compat
+version:             0.03
+abstract:            ~
+license:             ~
+author:              ~
+generated_by:        ExtUtils::MakeMaker version 6.44
+distribution_type:   module
+requires:     
+    Test::use::ok:                 0
+meta-spec:
+    url:     http://module-build.sourceforge.net/META-spec-v1.3.html
+    version: 1.3

Added: branches/upstream/libhash-util-fieldhash-compat-perl/current/Makefile.PL
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libhash-util-fieldhash-compat-perl/current/Makefile.PL?rev=37107&op=file
==============================================================================
--- branches/upstream/libhash-util-fieldhash-compat-perl/current/Makefile.PL (added)
+++ branches/upstream/libhash-util-fieldhash-compat-perl/current/Makefile.PL Mon Jun  1 08:44:09 2009
@@ -1,0 +1,23 @@
+#!/usr/bin/perl -w
+
+use strict;
+
+use ExtUtils::MakeMaker;
+
+my $have_fieldhash = eval { require Hash::Util::FieldHash };
+
+WriteMakefile(
+	NAME         => 'Hash::Util::FieldHash::Compat',
+	VERSION_FROM => 'lib/Hash/Util/FieldHash/Compat.pm',
+	INSTALLDIRS  => 'site',
+	SIGN         => 1,
+	PL_FILES     => { },
+	PREREQ_PM    => {
+		'Test::use::ok' => 0,
+		( $have_fieldhash ? () : (
+			'Tie::RefHash::Weak' => '0.08',
+			'Tie::RefHash' => '1.38',
+		)),
+	},
+);
+

Added: branches/upstream/libhash-util-fieldhash-compat-perl/current/SIGNATURE
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libhash-util-fieldhash-compat-perl/current/SIGNATURE?rev=37107&op=file
==============================================================================
--- branches/upstream/libhash-util-fieldhash-compat-perl/current/SIGNATURE (added)
+++ branches/upstream/libhash-util-fieldhash-compat-perl/current/SIGNATURE Mon Jun  1 08:44:09 2009
@@ -1,0 +1,30 @@
+This file contains message digests of all files listed in MANIFEST,
+signed via the Module::Signature module, version 0.55.
+
+To verify the content in this distribution, first make sure you have
+Module::Signature installed, then type:
+
+    % cpansign -v
+
+It will check each file's integrity, as well as the signature's
+validity.  If "==> Signature verified OK! <==" is not displayed,
+the distribution may already have been compromised, and you should
+not run its Makefile.PL or Build.PL.
+
+-----BEGIN PGP SIGNED MESSAGE-----
+Hash: SHA1
+
+SHA1 9eb4a1db910219bc6db59d1fbbe5a815ae2e461c MANIFEST
+SHA1 ddb918d4e02cc06f4b9fe77adeca65403f8fdd56 MANIFEST.SKIP
+SHA1 ad89fb0c2a789d0defb93b4bf37f66b319b118fc META.yml
+SHA1 918cf4ba21e63728463af696fafb92b119a0f8a7 Makefile.PL
+SHA1 80c417648fee8407f2c948f7acdac144bb4de2f3 lib/Hash/Util/FieldHash/Compat.pm
+SHA1 73e0f1080ea40335f0185b56a795086b7cb98ff0 lib/Hash/Util/FieldHash/Compat/Heavy.pm
+SHA1 53e9acad75268cbb65992a10808f7e2b538ca14e t/01_basic.t
+-----BEGIN PGP SIGNATURE-----
+Version: GnuPG v1.4.7 (Darwin)
+
+iD8DBQFILPUlVCwRwOvSdBgRAoIMAJoCBIZ0gnEU2I3s5dOYN/L4gBfKAwCgtp2T
+4JNeWSgeRVZNigH2YyPSj9M=
+=A2u7
+-----END PGP SIGNATURE-----

Added: branches/upstream/libhash-util-fieldhash-compat-perl/current/lib/Hash/Util/FieldHash/Compat.pm
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libhash-util-fieldhash-compat-perl/current/lib/Hash/Util/FieldHash/Compat.pm?rev=37107&op=file
==============================================================================
--- branches/upstream/libhash-util-fieldhash-compat-perl/current/lib/Hash/Util/FieldHash/Compat.pm (added)
+++ branches/upstream/libhash-util-fieldhash-compat-perl/current/lib/Hash/Util/FieldHash/Compat.pm Mon Jun  1 08:44:09 2009
@@ -1,0 +1,85 @@
+#!/usr/bin/perl
+
+package Hash::Util::FieldHash::Compat;
+
+use strict;
+use warnings;
+
+use constant REAL_FIELDHASH => do { local $@; eval { require Hash::Util::FieldHash } };
+
+BEGIN {
+	if ( REAL_FIELDHASH ) {
+		require Hash::Util::FieldHash;
+		Hash::Util::FieldHash->import(":all");
+	} else {
+		require Hash::Util::FieldHash::Compat::Heavy;
+	}
+}
+
+our $VERSION = "0.03";
+
+sub import {
+	if ( REAL_FIELDHASH ) {
+		my $class = "Hash::Util::FieldHash";
+
+		shift @_;
+		unshift @_, $class;
+
+		goto $class->can("import");
+	} else {
+		my $class = shift;
+		$class->export_to_level(1, $class, @_);
+	}
+}
+
+__PACKAGE__
+
+__END__
+
+=pod
+
+=head1 NAME
+
+Hash::Util::FieldHash::Compat - Use L<Hash::Util::FieldHash> or ties, depending
+on availability.
+
+=head1 SYNOPSIS
+
+	use Hash::Util::FieldHash::Compat;
+
+	# pretend you are using L<Hash::Util::FieldHash>
+	# under older perls it'll be Tie::RefHash::Weak instead (slower, but same behavior)
+
+=head1 DESCRIPTION
+
+Under older perls this module provides a drop in compatible api to
+L<Hash::Util::FieldHash> using L<perltie>. When L<Hash::Util::FieldHash> is
+available it will use that instead.
+
+This way code requiring field hashes can benefit from fast, robust field hashes
+on Perl 5.10 and newer, but still run on older perls that don't ship with that
+module.
+
+See L<Hash::Util::FieldHash> for all the details of the API.
+
+=head1 SEE ALSO
+
+L<Hash::Util::FieldHash>, L<Tie::RefHash>, L<Tie::RefHash::Weak>.
+
+=head1 VERSION CONTROL
+
+This module is maintained using Darcs. You can get the latest version from
+L<http://nothingmuch.woobling.org/code>, and use C<darcs send> to commit
+changes.
+
+=head1 AUTHOR
+
+Yuval Kogman E<lt>nothingmuch at woobling.orgE<gt>
+
+=head1 COPYRIGHT
+
+	Copyright (c) 2008 Yuval Kogman. All rights reserved
+	This program is free software; you can redistribute
+	it and/or modify it under the same terms as Perl itself.
+
+=cut

Added: branches/upstream/libhash-util-fieldhash-compat-perl/current/lib/Hash/Util/FieldHash/Compat/Heavy.pm
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libhash-util-fieldhash-compat-perl/current/lib/Hash/Util/FieldHash/Compat/Heavy.pm?rev=37107&op=file
==============================================================================
--- branches/upstream/libhash-util-fieldhash-compat-perl/current/lib/Hash/Util/FieldHash/Compat/Heavy.pm (added)
+++ branches/upstream/libhash-util-fieldhash-compat-perl/current/lib/Hash/Util/FieldHash/Compat/Heavy.pm Mon Jun  1 08:44:09 2009
@@ -1,0 +1,211 @@
+#!/usr/bin/perl
+
+package Hash::Util::FieldHash::Compat;
+
+use strict;
+use warnings;
+
+use Tie::RefHash::Weak;
+
+use vars qw(@ISA %EXPORT_TAGS @EXPORT_OK);
+
+ at ISA = qw(Exporter);
+
+%EXPORT_TAGS = (
+    'all' => [ qw(
+        fieldhash
+        fieldhashes
+        idhash
+        idhashes
+        id
+        id_2obj
+        register
+    )],
+);
+
+ at EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } );
+
+sub fieldhash (\%) {
+	my $hash = shift;
+
+	tie %$hash, 'Hash::Util::FieldHash::Compat::Tie::FieldHash', %$hash;
+
+	return $hash;
+}
+
+sub fieldhashes { map { &fieldhash($_) } @_ }
+
+sub idhash (\%) {
+	tie %{$_[0]}, 'Hash::Util::FieldHash::Compat::Tie::IdHash', %{$_[0]};
+	$_[0];
+}
+
+sub idhashes { map { &idhash($_) } @_ }
+
+sub id ($) {
+	my $obj = shift;
+
+	if ( defined ( my $refaddr = Tie::RefHash::refaddr($obj) ) ) {
+		return $refaddr;
+	} else {
+		return $obj;
+	}
+}
+
+tie my %registry, 'Tie::RefHash::Weak';
+
+sub id_2obj {
+	my $id = shift;
+
+	my $registry_by_id = tied(%registry)->[0];
+
+	if ( my $record = $registry_by_id->{$id} ) {
+		return $record->[0]; # first slot is the key
+	}
+
+	return;
+}
+
+sub register {
+	my ( $obj, @args ) = @_;
+	( $registry{$obj} ||= Hash::Util::FieldHash::Compat::Destroyer->new($obj) )->register(@args);
+}
+
+{
+	package Hash::Util::FieldHash::Compat::Tie::IdHash;
+	use Tie::Hash ();
+	use vars qw(@ISA);
+	@ISA = qw(Tie::StdHash);
+
+	# this class always stringifies using id().
+	
+	sub TIEHASH {
+		my ( $class, @args ) = @_;
+		my $self = bless {}, $class;
+
+		while ( @args ) {
+			my ( $key, $value ) = splice @args, 0, 2;
+			$self->STORE($key, $value);
+		}
+
+		$self;
+	}
+
+	BEGIN {
+		foreach my $method ( qw(STORE FETCH DELETE EXISTS) ) {
+			eval 'sub '.$method.' {
+				my ( $self, $key, @args ) = @_;
+				$self->SUPER::'.$method.'( Hash::Util::FieldHash::Compat::id($key), @args );
+			}';
+		}
+	}
+
+	package Hash::Util::FieldHash::Compat::Tie::FieldHash;
+	use vars qw(@ISA);
+	@ISA = qw(Tie::RefHash::Weak);
+
+	# this subclass retains weakrefs to the objects in the keys, but pretends
+	# the keys are actually strings
+
+	BEGIN {
+		# always return strings from keys
+
+		foreach my $method ( qw(FIRSTKEY NEXTKEY) ) {
+			eval 'sub '.$method.' {
+				my ( $self, @args ) = @_;
+				Hash::Util::FieldHash::Compat::id($self->SUPER::'.$method.'(@args));
+			}';
+		}
+
+		sub EXISTS {
+			my ( $self, $key ) = @_;
+			my $str_key = Hash::Util::FieldHash::Compat::id($key);
+			exists $_->{$str_key} and return 1 for @{ $self }[0, 1];
+			return;
+		}
+
+		sub FETCH {
+			my($self, $key) = @_;
+
+			my $str_key = Hash::Util::FieldHash::Compat::id($key);
+
+			if ( exists $self->[0]{$str_key} ) {
+				return $self->[0]{$str_key}[1];
+			} else {
+				$self->[1]{$str_key};
+			}
+		}
+
+		sub STORE {
+			my ( $self, $key, $value ) = @_;
+
+			my $str_key = Hash::Util::FieldHash::Compat::id($key);
+
+			delete $self->[1]{$str_key};
+
+			$self->SUPER::STORE( $key, $value );
+		}
+
+		sub DELETE {
+			my ( $self, $key ) = @_;
+
+			foreach my $key ( $key, Hash::Util::FieldHash::Compat::id($key) ) {
+				if ( defined ( my $ret = $self->SUPER::DELETE($key) ) ) {
+					return $ret;
+				}
+			}
+		}
+	}
+
+	package Hash::Util::FieldHash::Compat::Destroyer;
+	use Scalar::Util qw(weaken);
+
+	sub new {
+		my ( $class, $obj ) = @_;
+
+		tie my %hashes, 'Tie::RefHash::Weak';
+
+		my $self = bless {
+			object => $obj,
+			hashes => \%hashes,
+		}, $class;
+
+		weaken($self->{object});
+
+		$self;
+	}
+
+	sub register {
+		my ( $self, @hashes ) = @_;
+		$self->{hashes}{$_}++ for @hashes;
+	}
+
+	sub DESTROY {
+		my $self = shift;
+		my $object = $self->{object};
+		delete $_->{Hash::Util::FieldHash::Compat::id($object)} for keys %{ $self->{hashes} };
+	}
+}
+
+__PACKAGE__
+
+__END__
+
+=pod
+
+=head1 NAME
+
+Hash::Util::FieldHash::Compat::Heavy - Emulate Hash::Util::FieldHash using
+L<Tie::RefHash> etc.
+
+=head1 SYNOPSIS
+
+	# this module will be used automatically by L<Hash::Util::FieldHash::Compat> if necessary
+
+=head1 DESCRIPTION
+
+See L<Hash::Util::FieldHash::Compat> for the documentation
+
+=cut
+
+

Added: branches/upstream/libhash-util-fieldhash-compat-perl/current/t/01_basic.t
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libhash-util-fieldhash-compat-perl/current/t/01_basic.t?rev=37107&op=file
==============================================================================
--- branches/upstream/libhash-util-fieldhash-compat-perl/current/t/01_basic.t (added)
+++ branches/upstream/libhash-util-fieldhash-compat-perl/current/t/01_basic.t Mon Jun  1 08:44:09 2009
@@ -1,0 +1,100 @@
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More 'no_plan';
+
+use ok 'Hash::Util::FieldHash::Compat' => qw(fieldhash idhash register id id_2obj idhashes fieldhashes);
+
+{
+	my %hash = (
+		foo   => 'bar',
+		gorch => 'baz',
+	);
+
+	fieldhash %hash;
+
+	is_deeply( \%hash, { foo => 'bar', gorch => 'baz' }, 'setting fieldhash retains values' );
+
+	my $obj = bless {}, 'blah';
+
+	$hash{$obj} = 'oink';
+
+	is( scalar(keys %hash), 3, 'three keys now' );
+	is( scalar(grep { ref } keys %hash), 0, 'no refs in the keys' );
+
+	ok( !ref(id($obj)), 'id($obj) returns a nonref' );
+
+	ok( exists($hash{$obj}), 'key by ref' );
+	ok( exists($hash{id($obj)}), 'key by ref' );
+	is( $hash{$obj}, $hash{id($obj)}, '$hash{$obj} eq $hash{id($obj)}' );
+
+	undef $obj;
+
+	is( scalar(keys %hash), 2, '$obj key disappeared' );
+
+	my $destroyed = 0;
+	sub zot::DESTROY { $destroyed++ };
+
+	$obj = bless {}, "blah";
+
+	$hash{$obj} = bless {}, "zot";
+
+	is( $destroyed, 0, "no value destructions yet" );
+	is( scalar(keys %hash), 3, "three keys" );
+
+	undef $obj;
+
+	is( $destroyed, 1, "one value destroyed" );
+	is( scalar(keys %hash), 2, "two keys in hash" );
+}
+
+{
+
+	idhash my %id_hash;
+
+	my $obj = bless {}, "blah";
+
+	$id_hash{$obj} = "zoink";
+
+	is( scalar(keys %id_hash), 1, "one key in the hash" );
+	is_deeply([ keys %id_hash ], [ id($obj) ], "key is ID" );
+	ok( exists($id_hash{$obj}), 'key by ref' );
+	ok( exists($id_hash{id($obj)}), 'key by ref' );
+	is( $id_hash{$obj}, $id_hash{id($obj)}, '$hash{$obj} eq $hash{id($obj)}' );
+
+}
+
+{
+	my %hash;
+
+	my $obj_1 = bless {}, "blah";
+	my $obj_2 = bless {}, "blah";
+
+	$hash{id($obj_1)} = "first";
+	$hash{id($obj_2)} = "second";
+
+	is_deeply([ sort keys %hash ], [ sort map { id($_) } $obj_1, $obj_2 ], "keys" );
+
+	is( id_2obj(id($obj_1)), undef, "can't id_2obj yet" );
+	is( id_2obj(id($obj_2)), undef, "can't id_2obj yet" );
+
+	register($obj_1, \%hash);
+
+	is( id_2obj(id($obj_1)), $obj_1, "id_2obj on registered object" );
+	is( id_2obj(id($obj_2)), undef, "can't id_2obj on unregistered object" );
+
+	undef $obj_1;
+	undef $obj_2;
+
+	is( scalar(keys %hash), 1, "one key left" );
+	is_deeply([ values %hash ], [qw(second)], "second object remained" );
+}
+
+{
+	my @id_hashes = idhashes({ foo => "bar" }, { gorch => "baz" });
+	my @field_hashes = idhashes({ foo => "bar" }, { gorch => "baz" });
+
+	is_deeply($_, [{ foo => "bar" }, { gorch => "baz" }], "plural form") for \@id_hashes, \@field_hashes;
+}




More information about the Pkg-perl-cvs-commits mailing list