local-lib5/lib/perl5/Hash/Util/FieldHash/Compat/Heavy.pm

   1 #!/usr/bin/perl
   2
   3 package Hash::Util::FieldHash::Compat;
   4
   5 use strict;
   6 use warnings;
   7
   8 use Tie::RefHash::Weak;
   9
  10 use vars qw(@ISA %EXPORT_TAGS @EXPORT_OK);
  11
  12 @ISA = qw(Exporter);
  13
  14 %EXPORT_TAGS = (
  15     'all' => [ qw(
  16         fieldhash
  17         fieldhashes
  18         idhash
  19         idhashes
  20         id
  21         id_2obj
  22         register
  23     )],
  24 );
  25
  26 @EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } );
  27
  28 sub fieldhash (\%) {
  29         my $hash = shift;
  30
  31         tie %$hash, 'Hash::Util::FieldHash::Compat::Tie::FieldHash', %$hash;
  32
  33         return $hash;
  34 }
  35
  36 sub fieldhashes { map { &fieldhash($_) } @_ }
  37
  38 sub idhash (\%) {
  39         tie %{$_[0]}, 'Hash::Util::FieldHash::Compat::Tie::IdHash', %{$_[0]};
  40         $_[0];
  41 }
  42
  43 sub idhashes { map { &idhash($_) } @_ }
  44
  45 sub id ($) {
  46         my $obj = shift;
  47
  48         if ( defined ( my $refaddr = Tie::RefHash::refaddr($obj) ) ) {
  49                 return $refaddr;
  50         } else {
  51                 return $obj;
  52         }
  53 }
  54
  55 tie my %registry, 'Tie::RefHash::Weak';
  56
  57 sub id_2obj {
  58         my $id = shift;
  59
  60         my $registry_by_id = tied(%registry)->[0];
  61
  62         if ( my $record = $registry_by_id->{$id} ) {
  63                 return $record->[0]; # first slot is the key
  64         }
  65
  66         return;
  67 }
  68
  69 sub register {
  70         my ( $obj, @args ) = @_;
  71         ( $registry{$obj} ||= Hash::Util::FieldHash::Compat::Destroyer->new($obj) )->register(@args);
  72 }
  73
  74 {
  75         package Hash::Util::FieldHash::Compat::Tie::IdHash;
  76         use Tie::Hash ();
  77         use vars qw(@ISA);
  78         @ISA = qw(Tie::StdHash);
  79
  80         # this class always stringifies using id().
  81
  82         sub TIEHASH {
  83                 my ( $class, @args ) = @_;
  84                 my $self = bless {}, $class;
  85
  86                 while ( @args ) {
  87                         my ( $key, $value ) = splice @args, 0, 2;
  88                         $self->STORE($key, $value);
  89                 }
  90
  91                 $self;
  92         }
  93
  94         BEGIN {
  95                 foreach my $method ( qw(STORE FETCH DELETE EXISTS) ) {
  96                         eval 'sub '.$method.' {
  97                                 my ( $self, $key, @args ) = @_;
  98                                 $self->SUPER::'.$method.'( Hash::Util::FieldHash::Compat::id($key), @args );
  99                         }';
 100                 }
 101         }
 102
 103         package Hash::Util::FieldHash::Compat::Tie::FieldHash;
 104         use vars qw(@ISA);
 105         @ISA = qw(Tie::RefHash::Weak);
 106
 107         # this subclass retains weakrefs to the objects in the keys, but pretends
 108         # the keys are actually strings
 109
 110         BEGIN {
 111                 # always return strings from keys
 112
 113                 foreach my $method ( qw(FIRSTKEY NEXTKEY) ) {
 114                         eval 'sub '.$method.' {
 115                                 my ( $self, @args ) = @_;
 116                                 Hash::Util::FieldHash::Compat::id($self->SUPER::'.$method.'(@args));
 117                         }';
 118                 }
 119
 120                 sub EXISTS {
 121                         my ( $self, $key ) = @_;
 122                         my $str_key = Hash::Util::FieldHash::Compat::id($key);
 123                         exists $_->{$str_key} and return 1 for @{ $self }[0, 1];
 124                         return;
 125                 }
 126
 127                 sub FETCH {
 128                         my($self, $key) = @_;
 129
 130                         my $str_key = Hash::Util::FieldHash::Compat::id($key);
 131
 132                         if ( exists $self->[0]{$str_key} ) {
 133                                 return $self->[0]{$str_key}[1];
 134                         } else {
 135                                 $self->[1]{$str_key};
 136                         }
 137                 }
 138
 139                 sub STORE {
 140                         my ( $self, $key, $value ) = @_;
 141
 142                         my $str_key = Hash::Util::FieldHash::Compat::id($key);
 143
 144                         delete $self->[1]{$str_key};
 145
 146                         $self->SUPER::STORE( $key, $value );
 147                 }
 148
 149                 sub DELETE {
 150                         my ( $self, $key ) = @_;
 151
 152                         foreach my $key ( $key, Hash::Util::FieldHash::Compat::id($key) ) {
 153                                 if ( defined ( my $ret = $self->SUPER::DELETE($key) ) ) {
 154                                         return $ret;
 155                                 }
 156                         }
 157                 }
 158         }
 159
 160         package Hash::Util::FieldHash::Compat::Destroyer;
 161         use Scalar::Util qw(weaken);
 162
 163         sub new {
 164                 my ( $class, $obj ) = @_;
 165
 166                 tie my %hashes, 'Tie::RefHash::Weak';
 167
 168                 my $self = bless {
 169                         object => $obj,
 170                         hashes => \%hashes,
 171                 }, $class;
 172
 173                 weaken($self->{object});
 174
 175                 $self;
 176         }
 177
 178         sub register {
 179                 my ( $self, @hashes ) = @_;
 180                 $self->{hashes}{$_}++ for @hashes;
 181         }
 182
 183         sub DESTROY {
 184                 my $self = shift;
 185                 my $object = $self->{object};
 186                 delete $_->{Hash::Util::FieldHash::Compat::id($object)} for keys %{ $self->{hashes} };
 187         }
 188 }
 189
 190 __PACKAGE__
 191
 192 __END__
 193
 194 =pod
 195
 196 =head1 NAME
 197
 198 Hash::Util::FieldHash::Compat::Heavy - Emulate Hash::Util::FieldHash using
 199 L<Tie::RefHash> etc.
 200
 201 =head1 SYNOPSIS
 202
 203         # this module will be used automatically by L<Hash::Util::FieldHash::Compat> if necessary
 204
 205 =head1 DESCRIPTION
 206
 207 See L<Hash::Util::FieldHash::Compat> for the documentation
 208
 209 =cut
 210
 211