X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?p=catagits%2FGitalist.git;a=blobdiff_plain;f=local-lib5%2Flib%2Fperl5%2FTie%2FRefHash%2FWeak.pm;fp=local-lib5%2Flib%2Fperl5%2FTie%2FRefHash%2FWeak.pm;h=c75e3c036d28bf6478c6c7ad0a012faf0f6f7df0;hp=0000000000000000000000000000000000000000;hb=3fea05b9fbf95091f4522528b9980a33e0235603;hpb=af746827daa7a8feccee889e1d12ebc74cc9201e

diff --git a/local-lib5/lib/perl5/Tie/RefHash/Weak.pm b/local-lib5/lib/perl5/Tie/RefHash/Weak.pm
new file mode 100644
index 0000000..c75e3c0
--- /dev/null
+++ b/local-lib5/lib/perl5/Tie/RefHash/Weak.pm
@@ -0,0 +1,204 @@
+#!/usr/bin/perl
+
+package Tie::RefHash::Weak;
+use base qw/Tie::RefHash Exporter/;
+
+use strict;
+use warnings;
+
+use warnings::register;
+
+use overload ();
+
+use B qw/svref_2object CVf_CLONED/;
+
+our $VERSION = 0.09;
+our @EXPORT_OK = qw 'fieldhash fieldhashes';
+our %EXPORT_TAGS = ( all => \@EXPORT_OK );
+
+use Scalar::Util qw/weaken reftype/;
+use Variable::Magic qw/wizard cast getdata/;
+
+my $wiz = wizard free => \&_clear_weakened_sub, data => \&_add_magic_data;
+
+sub _clear_weakened_sub {
+	my ( $key, $objs ) = @_;
+	local $@;
+	foreach my $self ( grep { defined } @{ $objs || [] } ) {
+		eval { $self->_clear_weakened($key) }; # support subclassing
+	}
+}
+
+sub _add_magic_data {
+	my ( $key, $objects ) = @_;
+	$objects;
+}
+
+sub _clear_weakened {
+	my ( $self, $key ) = @_;
+
+	$self->DELETE( $key );
+}
+
+sub STORE {
+	my($s, $k, $v) = @_;
+
+	if (ref $k) {
+		# make sure we use the same function that RefHash is using for ref keys
+		my $kstr = Tie::RefHash::refaddr($k);
+		my $entry = [$k, $v];
+
+		weaken( $entry->[0] );
+
+		my $objects;
+
+		if ( reftype $k eq 'CODE' ) {
+			unless ( svref_2object($k)->CvFLAGS & CVf_CLONED ) {
+				warnings::warnif("Non closure code references never get garbage collected: $k");
+			} else {
+				$objects = &getdata ( $k, $wiz )
+					or &cast( $k, $wiz, ( $objects = [] ) );
+			}
+		} else {
+			$objects = &getdata( $k, $wiz )
+				or &cast( $k, $wiz, ( $objects = [] ) );
+		}
+
+		@$objects = grep { defined } @$objects;
+
+		unless ( grep { $_ == $s } @$objects ) {
+			push @$objects, $s;
+			weaken($objects->[-1]);
+		}
+
+		$s->[0]{$kstr} = $entry;
+	}
+	else {
+		$s->[1]{$k} = $v;
+	}
+
+	$v;
+}
+
+sub fieldhash(\%) {
+	tie %{$_[0]}, __PACKAGE__;
+	return $_[0];
+}
+
+sub fieldhashes {
+	tie %{$_}, __PACKAGE__ for @_;
+	return @_;
+}
+
+__PACKAGE__
+
+__END__
+
+=pod
+
+=head1 NAME
+
+Tie::RefHash::Weak - A Tie::RefHash subclass with weakened references in the keys.
+
+=head1 SYNOPSIS
+
+	use Tie::RefHash::Weak;
+	tie my %h, 'Tie::RefHash::Weak';
+
+	# OR:
+
+	use Tie::RefHash::Weak 'fieldhash';
+	fieldhash my %h;
+
+	{ # new scope
+		my $val = "foo";
+
+		$h{\$val} = "bar"; # key is weak ref
+	
+		print join(", ", keys %h); # contains \$val, returns regular reference
+	}
+	# $val goes out of scope, refcount goes to zero
+	# weak references to \$val are now undefined
+
+	keys %h; # no longer contains \$val
+
+	# see also Tie::RefHash
+
+=head1 DESCRIPTION
+
+The L<Tie::RefHash> module can be used to access hashes by reference. This is
+useful when you index by object, for example.
+
+The problem with L<Tie::RefHash>, and cross indexing, is that sometimes the
+index should not contain strong references to the objecs. L<Tie::RefHash>'s
+internal structures contain strong references to the key, and provide no
+convenient means to make those references weak.
+
+This subclass of L<Tie::RefHash> has weak keys, instead of strong ones. The
+values are left unaltered, and you'll have to make sure there are no strong
+references there yourself.
+
+=head1 FUNCTIONS
+
+For compatibility with L<Hash::Util::FieldHash>, this module will, upon
+request, export the following two functions. You may also write
+C<use Tie::RefHash::Weak ':all'>.
+
+=over 4
+
+=item fieldhash %hash
+
+This ties the hash and returns a reference to it.
+
+=item fieldhashes \%hash1, \%hash2 ...
+
+This ties each hash that is passed to it as a reference. It returns the
+list of references in list context, or the number of hashes in scalar
+context.
+
+=back
+
+=head1 THREAD SAFETY
+
+L<Tie::RefHash> version 1.32 and above have correct handling of threads (with
+respect to changing reference addresses). If your module requires
+Tie::RefHash::Weak to be thread aware you need to depend on both
+L<Tie::RefHash::Weak> and L<Tie::RefHash> version 1.32 (or later).
+
+Version 0.02 and later of Tie::RefHash::Weak depend on a thread-safe version of
+Tie::RefHash anyway, so if you are using the latest version this should already
+be taken care of for you.
+
+=head1 5.10.0 COMPATIBILITY
+
+Due to a minor change in Perl 5.10.0 a bug in the handling of magic freeing was
+uncovered causing segmentation faults.
+
+This has been patched but not released yet, as of 0.08.
+
+=head1 CAVEAT
+
+You can use an LVALUE reference (such as C<\substr ...>) as a hash key, but
+due to a bug in perl (see
+L<http://rt.perl.org/rt3/Public/Bug/Display.html?id=46943>) it might not be 
+possible to weaken a reference to it, in which case the hash element will 
+never be deleted automatically.
+
+=head1 AUTHORS
+
+Yuval Kogman <nothingmuch@woobling.org>
+
+some maintenance by Hans Dieter Pearcey <hdp@pobox.com>
+
+=head1 COPYRIGHT & LICENSE
+
+        Copyright (c) 2004 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.
+
+=head1 SEE ALSO
+
+L<Tie::RefHash>, L<Class::DBI> (the live object cache),
+L<mg.c/Perl_magic_killbackrefs>
+
+=cut