Skip to content

Commit 1dc73cb

Browse files
oodler577oodler577
committed
Added xshift_and_deref.
Also: * added unit test for xshift_and_deref * updated POD * cleaned up comments on existing tests * fixed reason for failing test on 5.8.9
1 parent 7c0d50f commit 1dc73cb

File tree

7 files changed

+135
-39
lines changed

7 files changed

+135
-39
lines changed

‎Changes

+8
Original file line numberDiff line numberDiff line change
@@ -86,3 +86,11 @@ Revision history for Dispatch::Fu.
8686
1.05 Thu Dec 14 01:02:01 2023
8787
- no functional changes
8888
- POD updates only
89+
90+
1.06 Sun Feb 18 12:02:33 2024
91+
- added the "xshift_and_deref" utility method that is great for
92+
eliminating boilerplate needed unpack references that are necessarily
93+
passed into "dispatch" or one of the static key handlers as the
94+
first element ("$_[0]") of "@_"
95+
- updated POD, added a test for "xshift_and_deref"
96+
- fixed tests failing for 5.8.9 (thanks @Bscan on Discord #perl!)

‎dist.ini

+1-1
Original file line numberDiff line numberDiff line change
@@ -2,7 +2,7 @@ name = Dispatch-Fu
22
author = oodler577 <oodler@cpan.org>
33
license = Perl_5
44
copyright_holder = oodler577
5-
copyright_year = 2023
5+
copyright_year = 2024
66
[@Basic]
77
[VersionFromModule]
88
[MetaJSON]

‎lib/Dispatch/Fu.pm

+52-10
Original file line numberDiff line numberDiff line change
@@ -5,9 +5,9 @@ use warnings;
55
use Exporter qw/import/;
66
use Carp qw/carp croak/;
77

8-
our $VERSION = q{1.05};
9-
our @EXPORT = qw(dispatch on cases xdefault);
10-
our @EXPORT_OK = qw(dispatch on cases xdefault);
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);
1111

1212
my $DISPATCH_TABLE = {};
1313

@@ -74,7 +74,14 @@ sub xdefault($;$) {
7474
if ($case and grep { /$case/ } (cases)){
7575
return $case;
7676
}
77-
return $default // q{default};
77+
return (defined $default) ? $default : q{default};
78+
}
79+
80+
# for multi-assignment syntax, given the first reference in the parameter list; e.g., "my ($x, $y, $z) = ..."
81+
sub xshift_and_deref(@) {
82+
return %{ +shift } if ref $_[0] eq q{HASH};
83+
return @{ +shift } if ref $_[0] eq q{ARRAY};
84+
return shift @_ if ref $_[0] eq q{SCALAR};
7885
}
7986

8087
# utility sub to force a BLOCK into a sub reference
@@ -86,6 +93,8 @@ sub _to_sub (&) {
8693

8794
__END__
8895
96+
=pod
97+
8998
=head1 NAME
9099
91100
Dispatch::Fu - Converts any complicated conditional dispatch situation into familiar static hash-key based dispatch
@@ -343,7 +352,7 @@ the way to pass arbitrary data into C<dispatch>. E.g.,
343352
...
344353
return $key;
345354
346-
} $INPUT, ## <><~ the single scalar reference to be passed to the C<dispatch> BLOCK
355+
} $INPUT, # <><~ the single scalar reference to be passed to the C<dispatch> BLOCK
347356
...
348357
349358
=item C<on>
@@ -368,8 +377,8 @@ BLOCK must return strictly only the keys that are defined via C<on>.
368377
on case4 => sub { my $INPUT = shift; ... },
369378
on case5 => sub { my $INPUT = shift; ... };
370379
371-
Note: when the subroutine associated with each I<case> is dispatched, the C<$INPUT> scalar is provide
372-
as input.
380+
Note: when the subroutine associated with each I<case> is dispatched, the
381+
C<$INPUT> scalar is provide as input.
373382
374383
my $INPUT = [qw/foo bar baz 1 3 4 5/];
375384
@@ -380,7 +389,7 @@ as input.
380389
...
381390
return $key;
382391
383-
} $INPUT, # <~ the single scalar reference to be passed to the C<dispatch> BLOCK
392+
} $INPUT, # <~ the single scalar reference to be passed to the C<dispatch> BLOCK
384393
on default => sub {
385394
my $INPUT = shift;
386395
do_default($INPUT);
@@ -394,6 +403,37 @@ as input.
394403
do_key2(qw/some other inputs entirely/);
395404
};
396405
406+
=item C<xshift_and_deref> ARRAY
407+
408+
Used within C<dispatch> and static key handlers defined by C<on> to provide a
409+
single statement for C<shift @_>, then an immediate I<dereferencing> of the
410+
C<SCALAR> reference based on it's reference I<type> based on the results of
411+
C<CORE::ref> (or just, C<ref>. E.g.,
412+
413+
my ($thing1, $thing2, $thing3) = xshift_and_deref @_;
414+
415+
And as part of a mostly complete C<dispatch> block,
416+
417+
dispatch {
418+
my ($thing1, $thing2, $thing3) = xshift_and_deref @_; # <~ HERE
419+
...
420+
return q{do_dis} if ...;
421+
return q{do_dat};
422+
} [ qw/thing1 thing2 thing3/ ],
423+
on do_dis => sub {
424+
my ($thing1, $thing2, $thing3) = xshift_and_deref @_; # <~ HERE
425+
...
426+
},
427+
on do_dat => sub {
428+
my ($thing1, $thing2, $thing3) = xshift_and_deref @_; # <~ HERE
429+
...
430+
};
431+
432+
This makes dealing with C<REF>s passed into C<dispatch> (and additinally into
433+
the static key handler) very convenient. It eliminates potentally many lines
434+
of boilerplate code that is meant simply for getting the contents of C<$_[0]>
435+
into a set of explicit variables inside of C<dispatch>.
436+
397437
=back
398438
399439
=head3 Diagnostics and Warnings
@@ -434,8 +474,8 @@ the misplaced semicolon below:
434474
This module will also throw an exeption (via C<croak>) if C<dispatch> is
435475
defined, but there are no C<on> statements. This covers the situation where
436476
a semicolon has also snuck in prematurely; E.g., the following examples will
437-
die because due to lack of C<on> cases before C<on> warns that it's being used
438-
in a useless context:
477+
die because due to lack of C<on> cases before C<on> warns that it's being
478+
used in a useless context:
439479
440480
my $result = dispatch {
441481
@@ -455,3 +495,5 @@ O. ODLER 558 L<< <oodler@cpan.org> >>.
455495
=head1 LICENSE AND COPYRIGHT
456496
457497
Same as Perl.
498+
499+
=cut

‎t/01-example.t

+12-12
Original file line numberDiff line numberDiff line change
@@ -5,17 +5,17 @@ use Test::More tests => 1;
55

66
my $INPUT = [qw/1 2 3 4 5/];
77

8-
my $results = dispatch { # <~ start of 'dispatch' construct
9-
my $input_ref = shift; # <~ input reference
10-
return ( scalar @$input_ref > 5 ) # <~ return a string that must be
11-
? q{case5} # defined below using the 'on'
12-
: sprintf qq{case%d}, scalar @$input_ref; # keyword, this i
13-
} $INPUT, # <~ input reference, SCALAR passed to dispatch BLOCK
14-
on case0 => sub { my $INPUT = shift; return qq{case 0}}, # <~ if dispatch returns 'case0', run this CODE
15-
on case1 => sub { my $INPUT = shift; return qq{case 1}}, # <~ if dispatch returns 'case1', run this CODE
16-
on case2 => sub { my $INPUT = shift; return qq{case 2}}, # ... ... ... ... ... ... ...
17-
on case3 => sub { my $INPUT = shift; return qq{case 3}}, # ... ... ... ... ... ... ... ...
18-
on case4 => sub { my $INPUT = shift; return qq{case 4}}, # ... ... ... ... ... ... ...
19-
on case5 => sub { my $INPUT = shift; return qq{case 5}}; # <~ if dispatch returns 'case5', run this CODE
8+
my $results = dispatch { # <~ start of 'dispatch' construct
9+
my $input_ref = shift; # <~ input reference
10+
return ( scalar @$input_ref > 5 ) # <~ return a string that must be
11+
? q{case5} # defined below using the 'on' keyword
12+
: sprintf qq{case%d}, scalar @$input_ref;
13+
} $INPUT, # <~ input reference, SCALAR passed to dispatch BLOCK
14+
on case0 => sub { my $INPUT = shift; return qq{case 0}}, # <~ if dispatch returns 'case0', run this CODE
15+
on case1 => sub { my $INPUT = shift; return qq{case 1}}, # <~ if dispatch returns 'case1', run this CODE
16+
on case2 => sub { my $INPUT = shift; return qq{case 2}}, # ... ... ... ... ... ... ...
17+
on case3 => sub { my $INPUT = shift; return qq{case 3}}, # ... ... ... ... ... ... ... ...
18+
on case4 => sub { my $INPUT = shift; return qq{case 4}}, # ... ... ... ... ... ... ...
19+
on case5 => sub { my $INPUT = shift; return qq{case 5}}; # <~ if dispatch returns 'case5', run this CODE
2020

2121
is $results, q{case 5}, q{POD example works};

‎t/02-xdefault.t

+6-4
Original file line numberDiff line numberDiff line change
@@ -1,4 +1,6 @@
1-
use Dispatch::Fu; # exports 'dispatch' and 'on', which are needed
1+
use strict;
2+
use warnings;
3+
use Dispatch::Fu;
24

35
use Test::More tests => 5;
46

@@ -40,7 +42,7 @@ $INPUT = q{not a case};
4042

4143
$results = dispatch {
4244
my $input_str = shift;
43-
xdefault $input_str; # if $input_str is not in supported cases, return the string 'default'
45+
xdefault $input_str; # if $input_str is not in supported cases, return the string 'default'
4446
}
4547
$INPUT,
4648
on default => sub { 6 },
@@ -57,7 +59,7 @@ $INPUT = undef;
5759

5860
$results = dispatch {
5961
my $input_str = shift;
60-
xdefault $input_str; # if $input_str is not in supported cases, return the string 'default'
62+
xdefault $input_str; # if $input_str is not in supported cases, return the string 'default'
6163
}
6264
$INPUT,
6365
on default => sub { 6 },
@@ -74,7 +76,7 @@ $INPUT = undef;
7476

7577
$results = dispatch {
7678
my $input_str = shift;
77-
xdefault $input_str, q{case0}; # if $input_str is not in supported cases, return the string 'default'
79+
xdefault $input_str, q{case0}; # if $input_str is not in supported cases, return the string 'default'
7880
}
7981
$INPUT,
8082
on default => sub { 6 },

‎t/04-return-values.t

+12-12
Original file line numberDiff line numberDiff line change
@@ -1,22 +1,22 @@
11
use strict;
22
use warnings;
3-
use Dispatch::Fu; # 'dispatch', 'cases', 'xdefault', and 'on' are exported by default, just for show here
3+
use Dispatch::Fu;
44
use Test::More tests => 3;
55

66
my $INPUT = [qw/1 2 3 4 5/];
77

88
my ($val0, $val1, $val2) = dispatch {
9-
my $input_ref = shift; # <~ input reference
10-
return ( scalar @$input_ref > 5 ) # <~ return a string that must be
11-
? q{case5} # defined below using the 'on'
12-
: sprintf qq{case%d}, scalar @$input_ref; # keyword, this i
13-
} $INPUT, # <~ input reference, SCALAR passed to dispatch BLOCK
14-
on case0 => sub { my $INPUT = shift; return qq{case 0}}, # <~ if dispatch returns 'case0', run this CODE
15-
on case1 => sub { my $INPUT = shift; return qq{case 1}}, # <~ if dispatch returns 'case1', run this CODE
16-
on case2 => sub { my $INPUT = shift; return qq{case 2}}, # ... ... ... ... ... ... ...
17-
on case3 => sub { my $INPUT = shift; return qq{case 3}}, # ... ... ... ... ... ... ... ...
18-
on case4 => sub { my $INPUT = shift; return qq{case 4}}, # ... ... ... ... ... ... ...
19-
on case5 => sub { my $INPUT = shift; return qw/val0 val1 val2/ }; # <~ if dispatch returns a LIST
9+
my $input_ref = shift; # <~ input reference
10+
return ( scalar @$input_ref > 5 ) # <~ return a string that must be
11+
? q{case5} # defined below using the 'on'
12+
: sprintf qq{case%d}, scalar @$input_ref; # keyword, this i
13+
} $INPUT, # <~ input reference, SCALAR passed to dispatch BLOCK
14+
on case0 => sub { my $INPUT = shift; return qq{case 0}}, # <~ if dispatch returns 'case0', run this CODE
15+
on case1 => sub { my $INPUT = shift; return qq{case 1}}, # <~ if dispatch returns 'case1', run this CODE
16+
on case2 => sub { my $INPUT = shift; return qq{case 2}}, # ... ... ... ... ... ... ...
17+
on case3 => sub { my $INPUT = shift; return qq{case 3}}, # ... ... ... ... ... ... ... ...
18+
on case4 => sub { my $INPUT = shift; return qq{case 4}}, # ... ... ... ... ... ... ...
19+
on case5 => sub { my $INPUT = shift; return qw/val0 val1 val2/ }; # <~ if dispatch returns a LIST
2020

2121

2222
is $val0, q{val0}, q{multi return val0 worked as expected};

‎t/05-xshift_and_deref.t

+44
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,44 @@
1+
use strict;
2+
use warnings;
3+
use Dispatch::Fu;
4+
use Test::More tests => 6;
5+
6+
my $INPUT = [qw/1 2 3 4 5/];
7+
8+
my ($val0, $val1, $val2) = dispatch {
9+
my @input_arr = xshift_and_deref @_; # <~ NOTE: derefs $_[0] into @input_arr
10+
return ( scalar @input_arr > 5 ) # <~ return a string that must be
11+
? q{case5} # defined below using the 'on' keyword
12+
: sprintf qq{case%d}, scalar @input_arr;
13+
} $INPUT, # <~ input reference, SCALAR passed to dispatch BLOCK
14+
on case0 => sub { my $INPUT = shift; return qq{case 0}}, # <~ if dispatch returns 'case0', run this CODE
15+
on case1 => sub { my $INPUT = shift; return qq{case 1}}, # <~ if dispatch returns 'case1', run this CODE
16+
on case2 => sub { my $INPUT = shift; return qq{case 2}}, # ... ... ... ... ... ... ...
17+
on case3 => sub { my $INPUT = shift; return qq{case 3}}, # ... ... ... ... ... ... ... ...
18+
on case4 => sub { my $INPUT = shift; return qq{case 4}}, # ... ... ... ... ... ... ...
19+
on case5 => sub { my $INPUT = shift; return qw/val0 val1 val2/ }; # <~ if dispatch returns a LIST
20+
21+
22+
is $val0, q{val0}, q{multi return val0 worked as expected};
23+
is $val1, q{val1}, q{multi return val1 worked as expected};
24+
is $val2, q{val2}, q{multi return val2 worked as expected};
25+
26+
$INPUT = { 1 => q{foo}, 2 => q{bar}, 3 => q{baz}, 4 => q{herp}, 5 => q{derp} };
27+
28+
($val0, $val1, $val2) = dispatch {
29+
my %input_hash = xshift_and_deref @_; # <~ NOTE: derefs $_[0] into %input_hash
30+
return ( scalar keys %input_hash > 5 ) # <~ return a string that must be
31+
? q{case5} # defined below using the 'on' keyword
32+
: sprintf qq{case%d}, scalar keys %input_hash;
33+
} $INPUT, # <~ input reference, SCALAR passed to dispatch BLOCK
34+
on case0 => sub { my $INPUT = shift; return qq{case 0}}, # <~ if dispatch returns 'case0', run this CODE
35+
on case1 => sub { my $INPUT = shift; return qq{case 1}}, # <~ if dispatch returns 'case1', run this CODE
36+
on case2 => sub { my $INPUT = shift; return qq{case 2}}, # ... ... ... ... ... ... ...
37+
on case3 => sub { my $INPUT = shift; return qq{case 3}}, # ... ... ... ... ... ... ... ...
38+
on case4 => sub { my $INPUT = shift; return qq{case 4}}, # ... ... ... ... ... ... ...
39+
on case5 => sub { my $INPUT = shift; return qw/val0 val1 val2/ }; # <~ if dispatch returns a LIST
40+
41+
42+
is $val0, q{val0}, q{multi return val0 worked as expected};
43+
is $val1, q{val1}, q{multi return val1 worked as expected};
44+
is $val2, q{val2}, q{multi return val2 worked as expected};

0 commit comments

Comments
 (0)