File Coverage

File:lib/Dispatch/Fu.pm
Coverage:100.0%

linestmtbrancondsubpodtimecode
1package Dispatch::Fu;
2
3
7
7
7
7
46
15
286
use strict;
4
7
7
7
7
38
13
347
use warnings;
5
7
7
7
7
35
9
223
use Exporter qw/import/;
6
7
7
7
7
53
21
4967
use Carp qw/carp croak/;
7
8our $VERSION       = q{1.06};
9our @EXPORT        = qw(dispatch on cases xdefault xshift_and_deref);
10our @EXPORT_OK     = qw(dispatch on cases xdefault xshift_and_deref);
11
12my $DISPATCH_TABLE = {};
13
14# sub for introspection, returns the string names of each case
15# added using the C<on> keyword
16sub cases() {
17
206
206
1
923
    return sort keys %$DISPATCH_TABLE;
18}
19
20sub _reset_default_handler() {
21    $DISPATCH_TABLE = {
22        default => sub {
23
1
1
96
            carp qq{Supported cases are:\n};
24
1
2
            foreach my $case (cases) {
25
1
10
                print qq{\t$case\n};
26            };
27        },
28
238
238
1648
    };
29
238
389
    return;
30}
31
32_reset_default_handler;
33
34sub dispatch (&@) {
35
118
118
1
139
    my $code_ref  = shift;    # catch sub ref that was coerced from the 'dispatch' BLOCK
36
118
120
    my $match_ref = shift;    # catch the input reference passed after the 'dispatch' BLOCK
37
38    # A failed dispatch can exit before the normal reset below. Start every
39    # dispatch from a clean table so cases never leak between calls.
40
118
202
    _reset_default_handler;
41
42
118
100
301
    croak qq{Dispatch::Fu [warning]: no cases defined. Make sure no semicolons are in places that need commas!} if not @_;
43
44    # build up dispatch table for each k/v pair preceded by 'on'
45
117
191
    while (@_) {
46
665
705
        my $key = shift @_;
47
665
571
        my $HV  = shift @_;
48
665
721
        $DISPATCH_TABLE->{$key} = _to_sub($HV);
49    }
50
51    # call $code_ref that needs to return a valid bucket name
52
117
212
    my $key = $code_ref->($match_ref);
53
54
117
100
100
1032
    croak qq{Computed static bucket "$key" not found\n} if not $DISPATCH_TABLE->{$key} or 'CODE' ne ref $DISPATCH_TABLE->{$key};
55
56    # call subroutine ref defined as the v in the k/v $DISPATCH_TABLE->{$key} slot
57
113
155
    my $sub_to_call = $DISPATCH_TABLE->{$key};
58
59    # Reset before invoking the selected handler so one dispatch cannot leak
60    # cases into the next call, even if the handler dies. C<cases> is intended
61    # for introspection while the classification block is running.
62
113
208
    _reset_default_handler;
63
64
113
189
    return $sub_to_call->($match_ref);
65}
66
67# on accumulator: accepts a key/value pair where the key is a static case name and the value is a subroutine reference
68sub on (@) {
69
667
667
1
873
    my ($key, $val) = @_;
70    # Detect situations where "on" follows a semicolon instead of a comma.
71
667
100
989
    carp qq{Dispatch::Fu [warning]: "on $key" used in void context is always a mistake. The "on" method always follows a comma!} unless wantarray;
72
667
1147
    return @_;
73}
74
75# if $case is in cases(), return $case; otherwise return $default
76# Note: $default defaults to q{default}; i.e., if the name of the
77# default case is not specified, the string 'default' is returned
78sub xdefault($;$) {
79
8
8
1
10
    my ($case, $default) = @_;
80
8
28
100
100
20
43
    if (defined $case and grep { $_ eq $case } cases) {
81
2
5
        return $case;
82    }
83
6
100
13
    return (defined $default) ? $default : q{default};
84}
85
86# for multi-assignment syntax, given the first reference in the parameter list; e.g., "my ($x, $y, $z) = ..."
87sub xshift_and_deref(@) {
88
4
1
100
4
1
12
4
    return %{ +shift } if ref $_[0] eq q{HASH};
89
3
1
100
6
2
    return @{ +shift } if ref $_[0] eq q{ARRAY};
90
2
1
100
4
2
    return ${ +shift } if ref $_[0] eq q{SCALAR};
91
1
3
    return;
92}
93
94# utility sub to force a BLOCK into a sub reference
95sub _to_sub (&) {
96
665
665
1303
    shift;
97}
98
991;
100