File Coverage

blib/lib/Sub/Infix.pm

Criterion	Covered	Total	%
statement	45	49	91.8
branch	20	24	83.3
condition	11	15	73.3
subroutine	16	19	84.2
pod	1	1	100.0
total	93	108	86.1

use 5.006;
use strict;
use warnings;

package Sub::Infix;

BEGIN {
	$Sub::Infix::AUTHORITY = 'cpan:TOBYINK';
	$Sub::Infix::VERSION   = '0.004';
}

use Exporter ();
our @ISA    = qw( Exporter );
our @EXPORT = qw( infix );

sub infix (&)
{
	my $code = shift;
	sub () { bless +{ code => $code }, "Sub::Infix::PartialApplication" };
}

{
	package Sub::Infix::PartialApplication;

	use Carp qw(croak);

	BEGIN {
		eval { require Scalar::Util; }
			? 'Scalar::Util'->import(qw/blessed/)
			: eval(q{
				require B;
				sub blessed ($) {
					return undef unless length(ref($_[0]));
					my $b = B::svref_2object($_[0]);
					return undef unless $b->isa('B::PVMG');
					my $s = $b->SvSTASH;
					return $s->isa('B::HV') ? $s->NAME : undef;
				}
			});
	};

	use overload
		q(|)   => sub { _apply($_[2] ? @_[1,0] : @_[0,1], "|") },
		q(/)   => sub { _apply($_[2] ? @_[1,0] : @_[0,1], "/") },
		q(<<)  => sub { _apply($_[2] ? @_[1,0] : @_[0,1], "<<") },
		q(>>)  => sub { _apply($_[2] ? @_[1,0] : @_[0,1], ">>") },
		q(&{}) => sub { $_[0]->{code} },
		q("")  => sub { !!1 },
		q(0+)  => sub { !!1 },
		q(bool)=> sub { !!1 },
	;

	sub _apply
	{
		my ($left, $right, $op) = @_;
		my $self;

		if (blessed $left and $left->isa(__PACKAGE__))
		{
			croak ">>infix<< not supported" if $op eq "<<";
			($self = $left)->{right} = $right;
		}
		elsif (blessed $right and $right->isa(__PACKAGE__))
		{
			croak ">>infix<< not supported" if $op eq ">>";
			($self = $right)->{left} = $left;
		}
		else
		{
			croak "incorrect usage of infix operator";
		}

		if (exists $self->{op})
		{
			my $combo = join "infix", sort $op, $self->{op};
			unless ($combo eq '<>' or $combo eq '/infix/'  or $combo eq '|infix|')
			{
				croak "$combo not supported";
			}
		}
		else
		{
			$self->{op} = $op;
		}

		if (exists $self->{left} and exists $self->{right})
		{
			return $self->{code}->($self->{left}, $self->{right});
		}

		return $self;
	}
}

1;

__END__