File Coverage

blib/lib/Dispatch/Fu.pm

Criterion	Covered	Total	%
statement	39	43	90.7
branch	12	16	75.0
condition	5	6	83.3
subroutine	11	12	91.6
pod	5	5	100.0
total	72	82	87.8

package Dispatch::Fu;

use strict;
use warnings;
use Exporter qw/import/;
use Carp qw/carp croak/;

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

my $DISPATCH_TABLE = {};

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

sub _reset_default_handler() {
    $DISPATCH_TABLE = {
        default => sub {
            carp qq{Supported cases are:\n};
            foreach my $case (cases) {
                print qq{\t$case\n};
            };
        },
    };
    return;
}

_reset_default_handler;

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);
    }

    croak qq{Dispatch::Fu [warning]: no cases defined. Make sure no semicolons are in places that need commas!} if not %$DISPATCH_TABLE;

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

    croak qq{Computed static bucket "$key" 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, happens after call to CODE ref so that C is available inside
    # of the body of the sub
    _reset_default_handler;

    return $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 (@) {
    my ($key, $val) = @_;
    # detect situations like when instead of a comma, "on" sits behind a semicolon
    carp qq{Dispatch::Fu [warning]: "on $key" used in void context is always a mistake. The "on" method always follows a comma!} unless wantarray;
    return @_;
}

# 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 (defined $default) ? $default : q{default};
}

# for multi-assignment syntax, given the first reference in the parameter list; e.g., "my ($x, $y, $z) = ..."
sub xshift_and_deref(@) {
    return %{ +shift } if ref $_[0] eq q{HASH};
    return @{ +shift } if ref $_[0] eq q{ARRAY};
    return shift @_    if ref $_[0] eq q{SCALAR};
}

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

1;

__END__