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