File Coverage

blib/lib/Perl6/Currying.pm

Criterion	Covered	Total	%
statement	31	32	96.8
branch	3	6	50.0
condition	4	6	66.6
subroutine	5	5	100.0
pod	1	1	100.0
total	44	50	88.0

package Perl6::Currying;

use Filter::Simple;
use Carp;

croak "Perl6::Placeholders should not be loaded before Perl6::Currying"
	if $INC{'Perl6/Placeholders.pm'};

my $name = qr/(?:\w+(?:::\w+)*)/;
my $scalar = qr/\s*\$\w+\s*/;
our $balbrack = qr{ (?: (?> [^{}]+ ) | \{ (??{ $balbrack }) \} )* }x;

sub prebind {
	my $sub = shift;
	croak "Odd list of bindings for prebind" if @_%2;
	my %bound = @_;
	my $proto = $prototype{$sub} ||= prototype($sub);
	croak "Can't prebind sub with prototype ($proto)"
		unless $proto =~ /^$scalar(,$scalar)*$/;
	croak "Can't prebind nonexistent parameter \$$_ of sub($proto)"
		foreach grep { $proto !~ /\$$_/ } keys %bound;
	my $parampos = $parampos{$sub} ||= do {
		my @params = $proto =~ /(\w+)/g;
		my %parampos; @parampos{@params} = 0..$#params; \%parampos;
	};
	my @bound = sort { $b->{pos} <=> $a->{pos} }
		    map { pos=>$parampos->{$_}, val=>$bound{$_}}, keys %bound;
	$proto =~ s/,?\$$_// for keys %bound;
	my $HOF = sub {
		splice @_, $bound[$_]{pos}, 0, $bound[$_]{val} for 0..$#bound;
		goto &$sub;
	};
	$prototype{$HOF} = $proto;
	return $HOF;
}

sub Perl6::Currying::Attributes::MODIFY_CODE_ATTRIBUTES {
	my( $package, $ref, @attrs) = @_;
	for my $i (reverse 0..$#attrs) {
		next unless $attrs[$i] =~ /^Prototype\((.*)\)$/;
		$prototype{$ref} = $1;
		splice @attrs, $i;
	}
	return @attrs;
}

push @UNIVERSAL::ISA, 'Perl6::Currying::Attributes';

FILTER_ONLY
	executable => sub {
		# Subroutine declarations
			s
			 gx;
			s
			 gx;
		# Method call syntax
			s{(&$name)\.prebind\(}
			 {Perl6::Currying::prebind(\\$1,}g;
			s{&?(\$$name)\.prebind\(}
			 {Perl6::Currying::prebind($1,}g;
			s{&\{($balbrack)\}\.prebind\(}
			 {Perl6::Currying::prebind($1,}g;
		# Indirect object syntax
			s[\bprebind\s*(&$name)\s*: ]
			 [Perl6::Currying::prebind \\$1,]g;
			s[\bprebind\s*&?(\$$name)\s*:]
			 [Perl6::Currying::prebind $1,]g;
			s[\bprebind\s*&\{($balbrack)\}\s*:]
			 [Perl6::Currying::prebind $1,]g;
		},

__END__