File Coverage

blib/lib/Sub/Operable.pm

Criterion	Covered	Total	%
statement	68	72	94.4
branch	11	20	55.0
condition			n/a
subroutine	18	18	100.0
pod	0	4	0.0
total	97	114	85.0

use 5.008009;
use strict;
use warnings;
use overload ();

package Sub::Operable;

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

use constant PREFIX_OPS => map split(/ /, $overload::ops{$_}), qw(
	unary
	func
);

use constant INFIX_OPS => map split(/ /, $overload::ops{$_}), qw(
	with_assign
	num_comparison
	3way_comparison
	str_comparison
	binary
	matching
);

'overload'->import(
	(map {
		my $op = $_;
		$op => sub {
			my $next = $_[0]->can('do_prefix_op') or die;
			splice(@_, 1, 0, $op); goto $next;
		}
	} PREFIX_OPS),
	(map {
		my $op = $_;
		$op => sub {
			my $next = $_[0]->can('do_infix_op') or die;
			splice(@_, 1, 0, $op); goto $next;
		}
	} INFIX_OPS),
);

use isa __PACKAGE__;

use Exporter::Shiny qw( isa_Sub_Operable subop );

sub new {
	my ( $class, $coderef ) = ( shift, @_ );
	my $wrapped = $class->build_wrapped_coderef( $coderef );
	bless $wrapped, $class;
}

sub build_wrapped_coderef {
	my ( $class, $orig ) = ( shift, @_ );
	return sub {
		my $has_subops = grep isa_Sub_Operable($_), @_;
		if ( $has_subops ) {
			my @args = @_;
			my $new = sub {
				my @inner_args = @_;
				@_ = ();
				foreach my $arg ( @args ) {
					push @_, isa_Sub_Operable($arg) ? $arg->(@inner_args) : $arg;
				}
				local *_ = \$_[0];
				&$orig;
			};
			return $class->new($new);
		}
		else {
			local *_ = \$_[0];
			&$orig;
		}
	};
}

sub do_infix_op {
	my ( $x, $op, $y, $swap ) = @_;
	my $class = ref($x);
	( $x, $y ) = ( $y, $x ) if $swap;

	my $code;

	if ( isa_Sub_Operable $x ) {
		if ( isa_Sub_Operable $y ) {
			$code = sprintf( 'sub { $x->(@_) %s $y->(@_) }', $op );
		}
		else {
			$code = sprintf( 'sub { $x->(@_) %s $y }', $op );
		}
	}
	else {
		if ( isa_Sub_Operable $y ) {
			$code = sprintf( 'sub { $x %s $y->(@_) }', $op );
		}
		else {
			$code = sprintf( 'sub { $x %s $y }', $op );
		}
	}

	$class->new( scalar eval $code );
}

sub do_prefix_op {
	my ( $x, $op ) = @_;
	my $class = ref($x);

	if ( $op eq 'neg' ) {
		$op = '-';
	}

	my $code;

	if ( isa_Sub_Operable $x ) {
		$code = sprintf( 'sub { %s $x->(@_) }', $op );
	}
	else {
		$code = sprintf( 'sub { %s $x }', $op );
	}

	my $coderef = eval $code;
	$class->new( $coderef );
}

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

1;

__END__