Hash-Util-FieldHash-Compat-0.03/0000755000076500007650000000000011013172447017742 5ustar nothingmuchnothingmuchHash-Util-FieldHash-Compat-0.03/lib/0000755000076500007650000000000011013172445020506 5ustar nothingmuchnothingmuchHash-Util-FieldHash-Compat-0.03/lib/Hash/0000755000076500007650000000000011013172445021371 5ustar nothingmuchnothingmuchHash-Util-FieldHash-Compat-0.03/lib/Hash/Util/0000755000076500007650000000000011013172445022306 5ustar nothingmuchnothingmuchHash-Util-FieldHash-Compat-0.03/lib/Hash/Util/FieldHash/0000755000076500007650000000000011013172445024135 5ustar nothingmuchnothingmuchHash-Util-FieldHash-Compat-0.03/lib/Hash/Util/FieldHash/Compat/0000755000076500007650000000000011013172445025360 5ustar nothingmuchnothingmuchHash-Util-FieldHash-Compat-0.03/lib/Hash/Util/FieldHash/Compat/Heavy.pm0000644000076500007650000000751211005701711026772 0ustar nothingmuchnothingmuch#!/usr/bin/perl package Hash::Util::FieldHash::Compat; use strict; use warnings; use Tie::RefHash::Weak; use vars qw(@ISA %EXPORT_TAGS @EXPORT_OK); @ISA = qw(Exporter); %EXPORT_TAGS = ( 'all' => [ qw( fieldhash fieldhashes idhash idhashes id id_2obj register )], ); @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 etc. =head1 SYNOPSIS # this module will be used automatically by L if necessary =head1 DESCRIPTION See L for the documentation =cut Hash-Util-FieldHash-Compat-0.03/lib/Hash/Util/FieldHash/Compat.pm0000644000076500007650000000351411013172314025714 0ustar nothingmuchnothingmuch#!/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 or ties, depending on availability. =head1 SYNOPSIS use Hash::Util::FieldHash::Compat; # pretend you are using L # 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 using L. When L 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 for all the details of the API. =head1 SEE ALSO L, L, L. =head1 VERSION CONTROL This module is maintained using Darcs. You can get the latest version from L, and use C to commit changes. =head1 AUTHOR Yuval Kogman Enothingmuch@woobling.orgE =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 Hash-Util-FieldHash-Compat-0.03/Makefile.PL0000644000076500007650000000071110746120312021707 0ustar nothingmuchnothingmuch#!/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', )), }, ); Hash-Util-FieldHash-Compat-0.03/MANIFEST0000644000076500007650000000046111013172445021072 0ustar nothingmuchnothingmuchlib/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) Hash-Util-FieldHash-Compat-0.03/MANIFEST.SKIP0000644000076500007650000000103410743416276021650 0ustar nothingmuchnothingmuch# 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+$ Hash-Util-FieldHash-Compat-0.03/META.yml0000644000076500007650000000060411013172445021211 0ustar nothingmuchnothingmuch--- #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 Hash-Util-FieldHash-Compat-0.03/SIGNATURE0000644000076500007650000000222511013172447021227 0ustar nothingmuchnothingmuchThis 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----- Hash-Util-FieldHash-Compat-0.03/t/0000755000076500007650000000000011013172445020203 5ustar nothingmuchnothingmuchHash-Util-FieldHash-Compat-0.03/t/01_basic.t0000644000076500007650000000453210745004523021757 0ustar nothingmuchnothingmuch#!/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; }