Commit | Line | Data |
3fea05b9 |
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 |