File Coverage

blib/lib/Class/DOES.pm
Criterion Covered Total %
statement 53 58 91.3
branch 13 14 92.8
condition 8 11 72.7
subroutine 12 12 100.0
pod 1 3 33.3
total 87 98 88.7


line stmt bran cond sub pod time code
1             package Class::DOES;
2              
3 4     4   2426 use 5.006001;
  4         14  
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   16 use strict;
  4         7  
  4         65  
22 4     4   15 use warnings;
  4         6  
  4         110  
23 4     4   18 use warnings::register;
  4         14  
  4         486  
24              
25 4     4   31 use Scalar::Util qw/blessed/;
  4         6  
  4         553  
26              
27             our $VERSION = "1.02";
28              
29             sub warnif {
30 7 100   7 0 420 if (warnings::enabled()) {
31 4         541 warnings::warn($_[0]);
32             }
33             }
34              
35             sub get_mro;
36             sub get_mro {
37 88     88 0 114 my ($class) = @_;
38              
39             defined &mro::get_linear_isa
40 88 50       169 and return @{ mro::get_linear_isa($class) };
  88         347  
41              
42 4     4   25 no strict "refs";
  4         6  
  4         721  
43 0         0 my @mro = $class;
44 0         0 for (@{"$class\::ISA"}) {
  0         0  
45 0         0 push @mro, get_mro $_;
46             }
47 0         0 return @mro;
48             }
49              
50             sub import {
51 22     22   8143 my (undef, @roles) = @_;
52 22         43 my $pkg = caller;
53              
54 22         26 my $meth;
55 22 100 66     302 $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     155 $meth = $pkg->can("isa")
61             and $meth != UNIVERSAL->can("isa")
62             and warnif "$pkg doesn't use \@ISA for inheritance";
63              
64 22         63 my %does = map +($_, 1), @roles;
65              
66 4     4   27 no strict "refs";
  4         5  
  4         551  
67              
68 22         34 *{"$pkg\::DOES"} = \%does;
  22         53  
69 22         29 *{"$pkg\::DOES"} = \&DOES;
  22         756  
70             }
71              
72             sub DOES {
73 88     88 1 1476 my ($obj, $role) = @_;
74              
75 88         179 my $class = blessed $obj;
76 88 100       176 defined $class or $class = $obj;
77              
78 88         122 my %mro;
79             # Yes, this is a list. Shut up with your 'better written as
80             # $mro{}' nonsense.
81 88         125 @mro{ (), get_mro $class } = ();
82 88         225 for (keys %mro) {
83 4     4   24 no strict "refs";
  4         8  
  4         500  
84 288 100       289 if (exists ${"$_\::DOES"}{$role}) {
  288         680  
85 34         39 my $rv = ${"$_\::DOES"}{$role};
  34         64  
86 34 100       56 unless ($rv) {
87 3         9 warnif "\$$_\::DOES{$role} is false, returning 1";
88 3         19 return 1;
89             }
90 31         97 return $rv;
91             }
92             }
93              
94 54         253 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