File Coverage

blib/lib/Smart/Dispatch.pm

Criterion	Covered	Total	%
statement	78	79	98.7
branch	8	18	44.4
condition	16	20	80.0
subroutine	25	26	96.1
pod			n/a
total	127	143	88.8

package Smart::Dispatch;

use 5.010;
use strict;

use Carp;
use Smart::Dispatch::Table ();
use Smart::Dispatch::Match ();

BEGIN {
	$Smart::Dispatch::AUTHORITY = 'cpan:TOBYINK';
	$Smart::Dispatch::VERSION   = '0.005';
}

use constant DEFAULT_MATCH_CLASS => (__PACKAGE__.'::Match');
use constant DEFAULT_TABLE_CLASS => (__PACKAGE__.'::Table');

our ($IN_FLIGHT, @LIST, @EXPORT);
BEGIN
{
	$Carp::Internal{$_}++
		foreach (__PACKAGE__, DEFAULT_MATCH_CLASS, DEFAULT_TABLE_CLASS);
	$IN_FLIGHT = 0;
	@LIST      = ();
	@EXPORT    = qw/dispatcher match match_using otherwise dispatch failover/;
}

use namespace::clean ();
use Sub::Exporter -setup => {
	exports => [
		dispatcher   => \&_build_dispatcher,
		match        => \&_build_match,
		match_using  => \&_build_match_using,
		otherwise    => \&_build_otherwise,
		dispatch     => \&_build_dispatch,
		failover     => \&_build_failover,
	],
	groups => [
		default      => [@EXPORT],
		tiny         => [qw/dispatcher match/],
	],
	collectors => [qw/class/],
	installer => sub {
		namespace::clean::->import(
			-cleanee => $_[0]{into},
			grep { !ref } @{ $_[1] },
		);
		goto \&Sub::Exporter::default_installer;
	},
};

sub _build_dispatcher
{
	my ($class, $name, $arg, $col) = @_;
	my $table_class =
		$arg->{class}
		// $col->{class}{table}
		// DEFAULT_TABLE_CLASS;

	return sub (&)
	{
		my $body = shift;
		local @LIST = ();
		local $IN_FLIGHT = 1;
		$body->();
		return $table_class->new(match_list => [@LIST]);
	}
}

sub _build_match
{
	my ($class, $name, $arg, $col) = @_;
	my $match_class =
		$arg->{class}
		// $col->{class}{match}
		// DEFAULT_MATCH_CLASS;

	return sub
	{
		croak "$name cannot be used outside dispatcher" unless $IN_FLIGHT;
		my ($condition, %args) = (@_ == 2) ? (shift, _k($_[-1]), shift) : (@_);
		push @LIST, $match_class->new(%args, test => $condition);
		return;
	}
}

sub _build_match_using
{
	my ($class, $name, $arg, $col) = @_;
	my $match_class =
		$arg->{class}
		// $col->{class}{match}
		// DEFAULT_MATCH_CLASS;

	return sub (&@)
	{
		croak "$name cannot be used outside dispatcher" unless $IN_FLIGHT;
		my ($condition, %args) = (@_ == 2) ? (shift, _k($_[-1]), shift) : (@_);
		push @LIST, $match_class->new(%args, test => $condition);
		return;
	}
}

sub _build_otherwise
{
	my ($class, $name, $arg, $col) = @_;
	my $match_class =
		$arg->{class}
		// $col->{class}{match}
		// DEFAULT_MATCH_CLASS;

	return sub
	{
		croak "$name cannot be used outside dispatcher" unless $IN_FLIGHT;
		my (%args) = (@_ == 1) ? (_k($_[-1]), shift) : (@_);
		push @LIST, $match_class->new(%args, is_unconditional => 1, test => sub {1});
		return;
	}
}

sub _build_dispatch
{
	my ($class, $name, $arg, $col) = @_;

	return sub (&)
	{
		croak "$name cannot be used outside dispatcher" unless $IN_FLIGHT;
		return('dispatch', shift);
	}
}

sub _build_failover
{
	my ($class, $name, $arg, $col) = @_;

	return sub (&)
	{
		croak "$name cannot be used outside dispatcher" unless $IN_FLIGHT;
		return('dispatch', shift, is_failover => 1);
	}
}

sub _k
{
	ref $_[0] eq 'CODE' ? 'dispatch' : 'value';
}

foreach my $f (@EXPORT)
{
	no strict 'refs';
	*{"$f"} = &{"_build_$f"}(__PACKAGE__, $f, {}, {});
}

__PACKAGE__
__END__