File Coverage

blib/lib/Dispatch/Fu.pm

Criterion	Covered	Total	%
statement	27	27	100.0
branch	3	4	75.0
condition	6	8	75.0
subroutine	8	8	100.0
pod	4	4	100.0
total	48	51	94.1

package Dispatch::Fu;

use strict;
use warnings;
use Exporter qw/import/;

our $VERSION       = q{0.99};
our @EXPORT        = qw(dispatch on cases xdefault);
our @EXPORT_OK     = qw(dispatch on cases xdefault);

my $DISPATCH_TABLE = {};

sub dispatch (&@) {
    my $code_ref  = shift;    # catch sub ref that was coerced from the 'dispatch' BLOCK
    my $match_ref = shift;    # catch the input reference passed after the 'dispatch' BLOCK

    # build up dispatch table for each k/v pair preceded by 'on'
    while ( my $key = shift @_ ) {
        my $HV = shift @_;
        $DISPATCH_TABLE->{$key} = _to_sub($HV);
    }

    # call $code_ref that needs to return a valid bucket name
    my $key = $code_ref->($match_ref);

    die qq{Computed static bucket not found\n} if not $DISPATCH_TABLE->{$key} or 'CODE' ne ref $DISPATCH_TABLE->{$key};

    # call subroutine ref defined as the v in the k/v $DISPATCH_TABLE->{$key} slot
    my $sub_to_call = $DISPATCH_TABLE->{$key};

    # reset table
    $DISPATCH_TABLE = {};

    # dispatch with $match_ref
    $sub_to_call->($match_ref);
}

# on accumulater, wants h => v pair, where h is a static bucket string and v is a sub ref
sub on (@) {
    return @_;
}

# sub for introspection, returns the string names of each case
# added using the C keyword
sub cases () {
    return keys %$DISPATCH_TABLE;
}

# if $case is in cases(), return $case; otherwise return $default
# Note: $default defaults to q{default}; i.e., if the name of the
# default case is not specified, the string 'default' is returned
sub xdefault($;$) {
  my ($case, $default) = @_;
  if ($case and grep { /$case/ } (cases)){
    return $case;
  }
  return $default // q{default};
}

# utility sub to force a BLOCK into a sub reference
sub _to_sub (&) {
    shift;
}

1;

__END__