view release on metacpan or  search on metacpan

lib/Tie/Reduce.pm  view on Meta::CPAN

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__

=pod

=encoding utf-8

=head1 NAME

Tie::Reduce - a scalar that reduces its old and new values to a single value

=head1 SYNOPSIS

  use Tie::Reduce;
  
  tie my $sum, "Tie::Reduce", sub { $a + $b }, 0;
  
  $sum = 1;
  $sum = 2;
  $sum = 3;
  $sum = 4;
  
  say $sum;  # 10