This file is indexed.

/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