File Coverage

blib/lib/Class/DOES.pm
Criterion Covered Total %
statement 58 59 98.3
branch 13 14 92.8
condition 8 11 72.7
subroutine 12 12 100.0
pod 1 3 33.3
total 92 99 92.9


line stmt bran cond sub pod time code
1             package Class::DOES;
2              
3 4     4   209323 use 5.006001;
  4         16  
  4         194  
4              
5             =head1 NAME
6              
7             Class::DOES - Provide a simple ->DOES override
8              
9             =head1 SYNOPSIS
10              
11             package My::Class;
12              
13             use Class::DOES qw/Some::Role/;
14              
15             if (My::Class->DOES("Some::Role")) {
16             #...
17             }
18              
19             =cut
20              
21 4     4   23 use strict;
  4         7  
  4         142  
22 4     4   98 use warnings;
  4         7  
  4         9964  
23 4     4   40 use warnings::register;
  4         13  
  4         1178  
24              
25 4     4   26 use Scalar::Util qw/blessed/;
  4         10  
  4         1486  
26              
27             our $VERSION = "1.00";
28              
29             sub warnif {
30 7 100   7 0 852 if (warnings::enabled()) {
31 4         954 warnings::warn($_[0]);
32             }
33             }
34              
35             sub get_mro;
36             sub get_mro {
37 403     403 0 539 my ($class) = @_;
38              
39 0         0 defined &mro::get_linear_isa
40 403 50       811 and return @{ mro::get_linear_isa($class) };
41              
42 4     4   23 no strict "refs";
  4         8  
  4         1382  
43 403         640 my @mro = $class;
44 403         414 for (@{"$class\::ISA"}) {
  403         1233  
45 315         593 push @mro, get_mro $_;
46             }
47 403         1373 return @mro;
48             }
49              
50             sub import {
51 22     22   27153 my (undef, @roles) = @_;
52 22         87 my $pkg = caller;
53              
54 22         33 my $meth;
55 22 100 66     684 $meth = $pkg->can("DOES")
      50        
      100        
56             and $meth != \&DOES
57             and $meth != (UNIVERSAL->can("DOES") || 0)
58             and warnif "$pkg has inherited an incompatible ->DOES";
59              
60 22 100 66     276 $meth = $pkg->can("isa")
61             and $meth != UNIVERSAL->can("isa")
62             and warnif "$pkg doesn't use \@ISA for inheritance";
63              
64 22         92 my %does = map +($_, 1), @roles;
65              
66 4     4   26 no strict "refs";
  4         7  
  4         2373  
67              
68 22         38 *{"$pkg\::DOES"} = \%does;
  22         62  
69 22         39 *{"$pkg\::DOES"} = \&DOES;
  22         4813  
70             }
71              
72             sub DOES {
73 88     88 1 135598 my ($obj, $role) = @_;
74              
75 88         308 my $class = blessed $obj;
76 88 100       253 defined $class or $class = $obj;
77              
78 88         104 my %mro;
79             # Yes, this is a list. Shut up with your 'better written as
80             # $mro{}' nonsense.
81 88         182 @mro{ (), get_mro $class } = ();
82 88         302 for (keys %mro) {
83 4     4   25 no strict "refs";
  4         8  
  4         933  
84 288 100       495 if (exists ${"$_\::DOES"}{$role}) {
  288         1056  
85 34         41 my $rv = ${"$_\::DOES"}{$role};
  34         94  
86 34 100       82 unless ($rv) {
87 3         11 warnif "\$$_\::DOES{$role} is false, returning 1";
88 3         21 return 1;
89             }
90 31         122 return $rv;
91             }
92             }
93              
94 54         399 return $obj->isa($role);
95             }
96              
97             =head1 DESCRIPTION
98              
99             Perl 5.10 introduced a new method in L: C.
100             This was added to support the concept of B. A role is an
101             interface (a set of methods, with associated semantics) that a class or
102             an object can implement, without necessarily inheriting from it. A class
103             declares that it implements a given role by overriding the C<< ->DOES >>
104             method to return true when passed the name of the role.
105              
106             This is all well and flexible, allowing advanced object systems like
107             L to implement the C<< ->DOES >> override as they see fit,
108             but what about ordinary classes that just want to declare they support a
109             known interface? That's what this module is for: you pass it a list of
110             roles on the C line, and it gives you a C<< ->DOES >> override that
111             returns true for
112              
113             =over 4
114              
115             =item - any role in the supplied list;
116              
117             =item - any class you inherit from;
118              
119             =item - any role supported by any class you inherit from.
120              
121             =back
122              
123             It makes the following assumptions:
124              
125             =over 4
126              
127             =item - All your inheritance happens through C<@ISA>.
128              
129             That is, you haven't overridden C<< ->isa >>.
130              
131             =item - Noone else has given you a C<< ->DOES >> method.
132              
133             That is, none of your superclasses have their own C<< ->DOES >> override
134             (other than one provided by this module).
135              
136             =back
137              
138             If it detects either of these at C time, it will issue a warning.
139              
140             =head2 Setting C<%DOES> directly.
141              
142             This module stores the roles you support in the C<%DOES> hash in your
143             package. If you want C<< ->DOES >> to return something other that C<1>
144             for a role you support, you can make an entry in your C<%DOES> hash
145             yourself and it will be picked up.
146              
147             You should not make entries with false values, as this would be very
148             confusing. If you do, then when C<< ->DOES >> is called it will return
149             C<1> instead of the given value, and will issue a warning.
150              
151             =head2 DIAGNOSTICS
152              
153             All of these can be disabled with
154              
155             no warnings "Class::DOES";
156              
157             =over 4
158              
159             =item %s has inherited an incompatible ->DOES
160              
161             You have issued C from a class that already has a C<<
162             ->DOES >> method. This inherited method will be completely ignored, so
163             any roles it claims to support will be lost.
164              
165             =item %s doesn't use @ISA for inheritance
166              
167             You have issued C from a class with an overriden C<<
168             ->isa >>. Since the exported C<< ->DOES >> method uses C<@ISA> to
169             determine inheritance, any extra classes C<< ->isa >> claims to inherit
170             from will not be checked for the requested role.
171              
172             =item $%s::DOES{%s} is false, returning 1
173              
174             C<< ->DOES >> has found a false entry in a C<%DOES> hash, and is
175             returning C<1> instead to indicate the role is supported.
176              
177             =back
178              
179             =head1 AUTHOR
180              
181             Copyright 2009 Ben Morrow .
182              
183             This program is licensed under the same terms as Perl.
184              
185             =head1 BUGS
186              
187             Please send bug reports to .
188              
189             =cut
190              
191             1;
192