File Coverage

blib/lib/Tie/Reduce.pm

Criterion	Covered	Total	%
statement	40	60	66.6
branch	3	6	50.0
condition			n/a
subroutine	11	16	68.7
pod	5	5	100.0
total	59	87	67.8

use 5.006001;
use strict;
use warnings;

package Tie::Reduce;

our $AUTHORITY = 'cpan:TOBYINK';
our $VERSION   = '0.003';

## suppresses warnings

sub import {
	my $class  = shift;
	my $caller = caller;
	eval "package $caller; our (\$a, \$b)";
}

## tie interface

sub TIESCALAR {
	my $class = shift;
	$class->new(@_);
}

sub FETCH {
	ref($_[0]) ne __PACKAGE__
		? $_[0]->get_value
		: $_[0][0];  # shortcut if not subclassed
}

sub STORE {
	# if subclassed
	if (ref($_[0]) ne __PACKAGE__) {
		# take non-optimal route
		my $av = $_[0]->can('assign_value');
		goto $av; # preserve caller
	}

	my ($self) = shift;
	my ($new_value) = @_;
	my ($old_value, $coderef) = @$self;

	my ($caller_a, $caller_b) = do {
		my $pkg = caller();
		no strict 'refs';
		\*{$pkg . '::a'}, \*{$pkg . '::b'};
	};
	local (*$caller_a, *$caller_b);

	*$caller_a = \$old_value;
	*$caller_b = \$new_value;

	$self->[0] = $coderef->($old_value, $new_value);
}

## OO interface

sub new {
	my $class = shift;
	my ($coderef, $initial_value) = @_;
	no warnings 'uninitialized';
	if (ref($coderef) ne 'CODE') {
		require Carp;
		Carp::croak("Expected coderef; got $coderef");
	}
	bless [$initial_value, $coderef] => $class;
}

sub get_value {
	$_[0][0];
}

sub set_value {
	$_[0][0] = $_[1];
}

sub assign_value {
	my ($self) = shift;
	my ($new_value) = @_;
	my $old_value = $self->get_value;

	my ($caller_a, $caller_b) = do {
		my $pkg = caller();
		no strict 'refs';
		\*{$pkg . '::a'}, \*{$pkg . '::b'};
	};
	local (*$caller_a, *$caller_b);

	*$caller_a = \$old_value;
	*$caller_b = \$new_value;

	$self->set_value( $self->get_coderef->($old_value, $new_value) );
}

sub get_coderef {
	$_[0][1];
}

sub _set_coderef {
	$_[0][1] = $_[1];
}

1;

__END__