File Coverage: lib/Dispatch/Fu.pm

# File Coverage

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

line | stmt | bran | cond | sub | pod | time | code
--- | --- | --- | --- | --- | --- | --- | ---
1 |  |  |  |  |  |  | package 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 |
8 |  |  |  |  |  |  | our $VERSION = q{1.06};
9 |  |  |  |  |  |  | our @EXPORT = qw(dispatch on cases xdefault xshift_and_deref);
10 |  |  |  |  |  |  | our @EXPORT_OK = qw(dispatch on cases xdefault xshift_and_deref);
11 |
12 |  |  |  |  |  |  | my $DISPATCH_TABLE = {};
13 |
14 |  |  |  |  |  |  | # sub for introspection, returns the string names of each case
15 |  |  |  |  |  |  | # added using the C<on> keyword
16 |  |  |  |  |  |  | sub cases() {
17 | 206 |  |  | 206 | 1 | 923 | return sort keys %$DISPATCH_TABLE;
18 |  |  |  |  |  |  | }
19 |
20 |  |  |  |  |  |  | sub _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 |
34 |  |  |  |  |  |  | sub 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
68 |  |  |  |  |  |  | sub 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
78 |  |  |  |  |  |  | sub 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) = ..."
87 |  |  |  |  |  |  | sub 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
95 |  |  |  |  |  |  | sub _to_sub (&) {
96 | 665 |  |  | 665 |  | 1303 | shift;
97 |  |  |  |  |  |  | }
98 |
99 |  |  |  |  |  |  | 1;
100 |