/usr/share/perl5/Dispatch/Class.pm is in libdispatch-class-perl 0.01-2.
This file is owned by root:root, with mode 0o644.
The actual contents of the file can be viewed below.
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 | package Dispatch::Class;
use warnings;
use strict;
our $VERSION = '0.01';
use Sub::Exporter -setup => {
exports => [
qw(
class_case
dispatch
)
],
};
use Scalar::Util qw(blessed);
sub class_case {
my @prototable = @_;
sub {
my ($x) = @_;
my $blessed = blessed $x;
my $ref = ref $x;
my $DOES;
my @table = @prototable;
while (my ($key, $value) = splice @table, 0, 2) {
return $value if
!defined $key ? !defined $x :
$key eq '*' ? 1 :
$key eq ':str' ? !$ref :
$key eq $ref ? 1 :
$blessed && ($DOES ||= $x->can('DOES') || 'isa', $x->$DOES($key))
;
}
()
}
}
sub dispatch {
my $chk = &class_case;
sub { ($chk->($_[0]) || return)->($_[0]) }
}
'ok'
__END__
=head1 NAME
Dispatch::Class - dispatch on the type (class) of an argument
=head1 SYNOPSIS
use Dispatch::Class qw(
class_case
dispatch
);
# analyze the class of an object
my $analyze = class_case(
'Some::Class' => 1,
'Other::Class' => 2,
'UNIVERSAL' => "???",
);
my $foo = $analyze->(Other::Class->new); # 2
my $bar = $analyze->(IO::Handle->new); # "???"
my $baz = $analyze->(["not an object"]); # undef
# build a dispatcher
my $dispatch = dispatch(
'Dog::Tiny' => sub { ... }, # handle objects of the class Dog::Tiny
'Dog' => sub { ... },
'Mammal' => sub { ... },
'Tree' => sub { ... },
'ARRAY' => sub { ... }, # handle array refs
':str' => sub { ... }, # handle non-reference strings
'*' => sub { ... }, # handle any value
);
# call the appropriate handler, passing $obj as an argument
my $result = $dispatch->($obj);
=head1 DESCRIPTION
This module offers a (mostly) simple way to check the class of an object and
handle specific cases specially.
=head2 Functions
The following functions are available and can be imported on request:
=over
=item C<class_case>
C<class_case> takes a list of C<KEY, VALUE> pairs and returns a code reference
that (when called on an object) will analyze the object's class according to
the rules described below and return the corresponding I<VALUE> of the first
matching I<KEY>.
Example:
my $subref = class_case(
KEY1 => VALUE1,
KEY2 => VALUE2,
...
);
my $value = $subref->($some_object);
This will check the class of C<$some_object> against C<KEY1>, C<KEY2>, ... in
order and return the corresponding C<VALUEn> of the first match. If no key
matches, an empty list/undef is returned in list/scalar context, respectively.
The following things can be used as keys:
=over
=item C<*>
This will match any value. No actual check is performed.
=item C<:str>
This special key will match any non-reference.
=item C<SCALAR>, C<ARRAY>, C<HASH>, ...
These values match references of the specified type even if they aren't objects
(i.e. not L<C<bless>ed|perlfunc/bless>). That is, for unblessed references the
string returned by L<C<ref>|perlfunc/ref> is compared with
L<C<eq>|perlop/"Equality Operators">.
=item CLASS
Any other string is interpreted as a class name and matches if the input value
is an object for which C<< $obj->isa($CLASS) >> is true. To match any kind of
object (blessed value), use the key C<'UNIVERSAL'>.
Starting with L<Perl 5.10.0|perl5100delta/UNIVERSAL::DOES()> Perl supports
checking for roles with L<C<DOES>|UNIVERSAL/obj-DOES-ROLE->, so
C<Dispatch::Class> actually uses C<< $obj->DOES($CLASS) >> instead of C<isa>.
This still returns true for normal base classes but it also accepts roles that
have been composed into the object's class.
=back
=item C<dispatch>
This works like C<class_case> above, but the I<VALUE>s must be code references
and get invoked automatically:
sub dispatch {
my $analyze = class_case @_;
sub {
my ($obj) = @_;
my $handler = $analyze->($obj) or return;
$handler->($obj)
}
}
That is, the matching object is passed on to the matched I<VALUE>s and the
return value of the inner sub is whatever the handler returns (or the empty
list/undef if no I<KEY> matches).
=back
This module uses L<C<Sub::Exporter>|Sub::Exporter>, so you can rename the
imported functions at L<C<use>|perlfunc/use> time.
=head1 SEE ALSO
L<Sub::Exporter>
=head1 AUTHOR
Lukas Mai, C<< <l.mai at web.de> >>
=head1 COPYRIGHT & LICENSE
Copyright 2013 Lukas Mai.
This program is free software; you can redistribute it and/or modify it
under the terms of either: the GNU General Public License as published
by the Free Software Foundation; or the Artistic License.
See http://dev.perl.org/licenses/ for more information.
=cut
|