File Coverage

blib/lib/Tie/RefHash/Weak.pm

Criterion	Covered	Total	%
statement	60	61	98.3
branch	12	14	85.7
condition			n/a
subroutine	14	14	100.0
pod	2	2	100.0
total	88	91	96.7

#!/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__