local-lib5/lib/perl5/Tie/RefHash/Weak.pm

   1 #!/usr/bin/perl
   2
   3 package Tie::RefHash::Weak;
   4 use base qw/Tie::RefHash Exporter/;
   5
   6 use strict;
   7 use warnings;
   8
   9 use warnings::register;
  10
  11 use overload ();
  12
  13 use B qw/svref_2object CVf_CLONED/;
  14
  15 our $VERSION = 0.09;
  16 our @EXPORT_OK = qw 'fieldhash fieldhashes';
  17 our %EXPORT_TAGS = ( all => \@EXPORT_OK );
  18
  19 use Scalar::Util qw/weaken reftype/;
  20 use Variable::Magic qw/wizard cast getdata/;
  21
  22 my $wiz = wizard free => \&_clear_weakened_sub, data => \&_add_magic_data;
  23
  24 sub _clear_weakened_sub {
  25         my ( $key, $objs ) = @_;
  26         local $@;
  27         foreach my $self ( grep { defined } @{ $objs || [] } ) {
  28                 eval { $self->_clear_weakened($key) }; # support subclassing
  29         }
  30 }
  31
  32 sub _add_magic_data {
  33         my ( $key, $objects ) = @_;
  34         $objects;
  35 }
  36
  37 sub _clear_weakened {
  38         my ( $self, $key ) = @_;
  39
  40         $self->DELETE( $key );
  41 }
  42
  43 sub STORE {
  44         my($s, $k, $v) = @_;
  45
  46         if (ref $k) {
  47                 # make sure we use the same function that RefHash is using for ref keys
  48                 my $kstr = Tie::RefHash::refaddr($k);
  49                 my $entry = [$k, $v];
  50
  51                 weaken( $entry->[0] );
  52
  53                 my $objects;
  54
  55                 if ( reftype $k eq 'CODE' ) {
  56                         unless ( svref_2object($k)->CvFLAGS & CVf_CLONED ) {
  57                                 warnings::warnif("Non closure code references never get garbage collected: $k");
  58                         } else {
  59                                 $objects = &getdata ( $k, $wiz )
  60                                         or &cast( $k, $wiz, ( $objects = [] ) );
  61                         }
  62                 } else {
  63                         $objects = &getdata( $k, $wiz )
  64                                 or &cast( $k, $wiz, ( $objects = [] ) );
  65                 }
  66
  67                 @$objects = grep { defined } @$objects;
  68
  69                 unless ( grep { $_ == $s } @$objects ) {
  70                         push @$objects, $s;
  71                         weaken($objects->[-1]);
  72                 }
  73
  74                 $s->[0]{$kstr} = $entry;
  75         }
  76         else {
  77                 $s->[1]{$k} = $v;
  78         }
  79
  80         $v;
  81 }
  82
  83 sub fieldhash(\%) {
  84         tie %{$_[0]}, __PACKAGE__;
  85         return $_[0];
  86 }
  87
  88 sub fieldhashes {
  89         tie %{$_}, __PACKAGE__ for @_;
  90         return @_;
  91 }
  92
  93 __PACKAGE__
  94
  95 __END__
  96
  97 =pod
  98
  99 =head1 NAME
 100
 101 Tie::RefHash::Weak - A Tie::RefHash subclass with weakened references in the keys.
 102
 103 =head1 SYNOPSIS
 104
 105         use Tie::RefHash::Weak;
 106         tie my %h, 'Tie::RefHash::Weak';
 107
 108         # OR:
 109
 110         use Tie::RefHash::Weak 'fieldhash';
 111         fieldhash my %h;
 112
 113         { # new scope
 114                 my $val = "foo";
 115
 116                 $h{\$val} = "bar"; # key is weak ref
 117
 118                 print join(", ", keys %h); # contains \$val, returns regular reference
 119         }
 120         # $val goes out of scope, refcount goes to zero
 121         # weak references to \$val are now undefined
 122
 123         keys %h; # no longer contains \$val
 124
 125         # see also Tie::RefHash
 126
 127 =head1 DESCRIPTION
 128
 129 The L<Tie::RefHash> module can be used to access hashes by reference. This is
 130 useful when you index by object, for example.
 131
 132 The problem with L<Tie::RefHash>, and cross indexing, is that sometimes the
 133 index should not contain strong references to the objecs. L<Tie::RefHash>'s
 134 internal structures contain strong references to the key, and provide no
 135 convenient means to make those references weak.
 136
 137 This subclass of L<Tie::RefHash> has weak keys, instead of strong ones. The
 138 values are left unaltered, and you'll have to make sure there are no strong
 139 references there yourself.
 140
 141 =head1 FUNCTIONS
 142
 143 For compatibility with L<Hash::Util::FieldHash>, this module will, upon
 144 request, export the following two functions. You may also write
 145 C<use Tie::RefHash::Weak ':all'>.
 146
 147 =over 4
 148
 149 =item fieldhash %hash
 150
 151 This ties the hash and returns a reference to it.
 152
 153 =item fieldhashes \%hash1, \%hash2 ...
 154
 155 This ties each hash that is passed to it as a reference. It returns the
 156 list of references in list context, or the number of hashes in scalar
 157 context.
 158
 159 =back
 160
 161 =head1 THREAD SAFETY
 162
 163 L<Tie::RefHash> version 1.32 and above have correct handling of threads (with
 164 respect to changing reference addresses). If your module requires
 165 Tie::RefHash::Weak to be thread aware you need to depend on both
 166 L<Tie::RefHash::Weak> and L<Tie::RefHash> version 1.32 (or later).
 167
 168 Version 0.02 and later of Tie::RefHash::Weak depend on a thread-safe version of
 169 Tie::RefHash anyway, so if you are using the latest version this should already
 170 be taken care of for you.
 171
 172 =head1 5.10.0 COMPATIBILITY
 173
 174 Due to a minor change in Perl 5.10.0 a bug in the handling of magic freeing was
 175 uncovered causing segmentation faults.
 176
 177 This has been patched but not released yet, as of 0.08.
 178
 179 =head1 CAVEAT
 180
 181 You can use an LVALUE reference (such as C<\substr ...>) as a hash key, but
 182 due to a bug in perl (see
 183 L<http://rt.perl.org/rt3/Public/Bug/Display.html?id=46943>) it might not be
 184 possible to weaken a reference to it, in which case the hash element will
 185 never be deleted automatically.
 186
 187 =head1 AUTHORS
 188
 189 Yuval Kogman <nothingmuch@woobling.org>
 190
 191 some maintenance by Hans Dieter Pearcey <hdp@pobox.com>
 192
 193 =head1 COPYRIGHT & LICENSE
 194
 195         Copyright (c) 2004 Yuval Kogman. All rights reserved
 196         This program is free software; you can redistribute
 197         it and/or modify it under the same terms as Perl itself.
 198
 199 =head1 SEE ALSO
 200
 201 L<Tie::RefHash>, L<Class::DBI> (the live object cache),
 202 L<mg.c/Perl_magic_killbackrefs>
 203
 204 =cut