{ package Smart::Dispatch::ConditionList; use Any::Moose; use overload '&{}' => sub { my $x=shift; sub { $x->run($_[0]) } }, '.' => sub { (shift)->run(shift) }, '~~' => sub { (shift)->exists(shift) }; has conditions => ( is => 'ro', isa => 'ArrayRef[Smart::Dispatch::Condition]', required => 1, ); sub exists { my ($self, $value) = @_; foreach my $cond (@{ $self->conditions }) { if ($cond->value_matches($value)) { return $cond; } } return; } sub run { my ($self, $value, @args) = @_; my $cond = $self->exists($value); return $cond->conduct_dispatch($value, @args) if $cond; return; } } { package Smart::Dispatch::Condition; use Any::Moose; has test => ( is => 'ro', required => 1, ); has dispatch => ( is => 'ro', required => 0, ); has value => ( is => 'ro', required => 0, predicate => 'has_value', ); has note => ( is => 'ro', isa => 'Str', required => 0, ); sub value_matches { my ($self, $value) = @_; local $_ = $value; return ($value ~~ $self->test); } sub conduct_dispatch { my ($self, $value, @args) = @_; local $_ = $value; if (ref $self->dispatch eq 'CODE') { return $self->dispatch->($value, @args); } elsif ($self->has_value) { return $self->value; } else { warn "dispatch is not a code ref!"; return $self->dispatch; } } } { package Smart::Dispatch; use Carp; use parent qw/Exporter/; our ($IN_FLIGHT, @LIST, @EXPORT); BEGIN { $IN_FLIGHT = 0; @LIST; @EXPORT = qw/dispatcher match match_using dispatch otherwise/; } sub dispatcher (&) { my $builder = shift; local @LIST = (); local $IN_FLIGHT = 1; $builder->(); return Smart::Dispatch::ConditionList->new(conditions => [@LIST]); }; sub match { croak "match cannot be used outside dispatcher" unless $IN_FLIGHT; my ($condition, %args) = (@_ == 2) ? (shift, _k($_[-1]), shift) : (@_); push @LIST, Smart::Dispatch::Condition->new(test => $condition, %args); return; } sub match_using (&@) { croak "match_using cannot be used outside dispatcher" unless $IN_FLIGHT; goto \&match; } sub dispatch (&) { croak "dispatch cannot be used outside dispatcher" unless $IN_FLIGHT; return('dispatch', shift); } sub otherwise { croak "otherwise cannot be used outside dispatcher" unless $IN_FLIGHT; my (%args) = (@_ == 1) ? (_k($_[-1]), shift) : (@_); push @LIST, Smart::Dispatch::Condition->new(test => sub {1}, %args); return; } sub _k { ref $_[0] eq 'CODE' ? 'dispatch' : 'value'; } }