File Coverage

blib/lib/Class/MOP/Mixin/HasOverloads.pm
Criterion Covered Total %
statement 85 85 100.0
branch 16 18 88.8
condition 10 12 83.3
subroutine 21 21 100.0
pod 0 9 0.0
total 132 145 91.0


line stmt bran cond sub pod time code
1             package Class::MOP::Mixin::HasOverloads;
2             our $VERSION = '2.2206';
3              
4 450     450   5571 use strict;
  450         1084  
  450         13972  
5 450     450   2495 use warnings;
  450         987  
  450         12368  
6              
7 450     450   206348 use Class::MOP::Overload;
  450         1430  
  450         20552  
8              
9 450     450   230440 use Devel::OverloadInfo 0.005 'overload_info', 'overload_op_info';
  450         850690  
  450         28266  
10 450     450   3398 use Scalar::Util 'blessed';
  450         1119  
  450         16411  
11              
12 450     450   2845 use overload ();
  450         998  
  450         7404  
13              
14 450     450   2163 use parent 'Class::MOP::Mixin';
  450         967  
  450         2433  
15              
16             sub is_overloaded {
17 1974     1974 0 7802 my $self = shift;
18 1974         10527 Devel::OverloadInfo::is_overloaded($self->name);
19             }
20              
21             sub get_overload_list {
22 35     35 0 2356 my $self = shift;
23              
24 35         144 my $info = $self->_overload_info;
25 35         153821 return grep { $_ ne 'fallback' } keys %{$info}
  55         295  
  35         162  
26             }
27              
28             sub get_all_overloaded_operators {
29 30     30 0 87 my $self = shift;
30 30         154 return map { $self->_overload_for($_) } $self->get_overload_list;
  32         199  
31             }
32              
33             sub has_overloaded_operator {
34 26     26 0 3557 my $self = shift;
35 26         64 my ($op) = @_;
36 26         126 return defined $self->_overload_info_for($op);
37             }
38              
39             sub _overload_map {
40 63   50 63   338 $_[0]->{_overload_map} ||= {};
41             }
42              
43             sub get_overloaded_operator {
44 8     8 0 547 my $self = shift;
45 8         24 my ($op) = @_;
46 8   100     28 return $self->_overload_map->{$op} ||= $self->_overload_for($op);
47             }
48              
49 450     450   145190 use constant _SET_FALLBACK_EACH_TIME => "$]" < 5.120;
  450         2443  
  450         344709  
50              
51             sub add_overloaded_operator {
52 18     18 0 1704 my $self = shift;
53 18         65 my ( $op, $overload ) = @_;
54              
55 18         67 my %p = ( associated_metaclass => $self );
56 18 100       144 if ( !ref $overload ) {
    100          
57 1         7 %p = (
58             %p,
59             operator => $op,
60             method_name => $overload,
61             associated_metaclass => $self,
62             );
63 1 50       8 $p{method} = $self->get_method($overload)
64             if $self->has_method($overload);
65 1         7 $overload = Class::MOP::Overload->new(%p);
66             }
67             elsif ( !blessed $overload) {
68 1         15 my ($coderef_package, $coderef_name) = Class::MOP::get_code_info($overload);
69 1         8 $overload = Class::MOP::Overload->new(
70             operator => $op,
71             coderef => $overload,
72             coderef_name => $coderef_name,
73             coderef_package => $coderef_package,
74             %p,
75             );
76             }
77              
78 18         124 $overload->attach_to_class($self);
79 18         99 $self->_overload_map->{$op} = $overload;
80              
81 18 100       99 my %overload = (
82             $op => $overload->has_coderef
83             ? $overload->coderef
84             : $overload->method_name
85             );
86              
87             # Perl 5.10 and earlier appear to have a bug where setting a new
88             # overloading operator wipes out the fallback value unless we pass it each
89             # time.
90 18         44 if (_SET_FALLBACK_EACH_TIME) {
91 18         514 $overload{fallback} = $self->get_overload_fallback_value;
92             }
93              
94 18         1816 $self->name->overload::OVERLOAD(%overload);
95             }
96              
97             sub remove_overloaded_operator {
98 2     2 0 14 my $self = shift;
99 2         6 my ($op) = @_;
100              
101 2         7 delete $self->_overload_map->{$op};
102              
103             # overload.pm provides no api for this - but the problem that makes this
104             # necessary has been fixed in 5.18
105 2 50       15 $self->get_or_add_package_symbol('%OVERLOAD')->{dummy}++
106             if "$]" < 5.017000;
107              
108 2         18 $self->remove_package_symbol('&(' . $op);
109             }
110              
111             sub get_overload_fallback_value {
112 47     47 0 119 my $self = shift;
113 47   100     215 return ($self->_overload_info_for('fallback') || {})->{value};
114             }
115              
116             sub set_overload_fallback_value {
117 15     15 0 1180 my $self = shift;
118 15         42 my $value = shift;
119              
120 15         106 $self->name->overload::OVERLOAD( fallback => $value );
121             }
122              
123             # We could cache this but we'd need some logic to clear it at all the right
124             # times, which seems more tedious than it's worth.
125             sub _overload_info {
126 35     35   70 my $self = shift;
127 35   50     182 return overload_info( $self->name ) || {};
128             }
129              
130             sub _overload_info_for {
131 94     94   180 my $self = shift;
132 94         158 my $op = shift;
133 94         394 return overload_op_info( $self->name, $op );
134             }
135              
136             sub _overload_for {
137 35     35   83 my $self = shift;
138 35         72 my $op = shift;
139              
140 35         147 my $map = $self->_overload_map;
141 35 100       159 return $map->{$op} if $map->{$op};
142              
143 21         76 my $info = $self->_overload_info_for($op);
144 21 100       2155 return unless $info;
145              
146 19         113 my %p = (
147             operator => $op,
148             associated_metaclass => $self,
149             );
150              
151 19 100 100     162 if ( $info->{code} && !$info->{method_name} ) {
152 3         10 $p{coderef} = $info->{code};
153             @p{ 'coderef_package', 'coderef_name' }
154 3         30 = $info->{code_name} =~ /(.+)::([^:]+)/;
155             }
156             else {
157 16         53 $p{method_name} = $info->{method_name};
158 16 100       154 if ( $self->has_method( $p{method_name} ) ) {
159 14         81 $p{method} = $self->get_method( $p{method_name} );
160             }
161             }
162              
163 19         182 return $map->{$op} = Class::MOP::Overload->new(%p);
164             }
165              
166             1;
167              
168             # ABSTRACT: Methods for metaclasses which have overloads
169              
170             __END__
171              
172             =pod
173              
174             =encoding UTF-8
175              
176             =head1 NAME
177              
178             Class::MOP::Mixin::HasOverloads - Methods for metaclasses which have overloads
179              
180             =head1 VERSION
181              
182             version 2.2206
183              
184             =head1 DESCRIPTION
185              
186             This class implements methods for metaclasses which have overloads
187             (L<Class::MOP::Clas> and L<Moose::Meta::Role>). See L<Class::MOP::Class> for
188             API details.
189              
190             =head1 AUTHORS
191              
192             =over 4
193              
194             =item *
195              
196             Stevan Little <stevan@cpan.org>
197              
198             =item *
199              
200             Dave Rolsky <autarch@urth.org>
201              
202             =item *
203              
204             Jesse Luehrs <doy@cpan.org>
205              
206             =item *
207              
208             Shawn M Moore <sartak@cpan.org>
209              
210             =item *
211              
212             יובל קוג'מן (Yuval Kogman) <nothingmuch@woobling.org>
213              
214             =item *
215              
216             Karen Etheridge <ether@cpan.org>
217              
218             =item *
219              
220             Florian Ragwitz <rafl@debian.org>
221              
222             =item *
223              
224             Hans Dieter Pearcey <hdp@cpan.org>
225              
226             =item *
227              
228             Chris Prather <chris@prather.org>
229              
230             =item *
231              
232             Matt S Trout <mstrout@cpan.org>
233              
234             =back
235              
236             =head1 COPYRIGHT AND LICENSE
237              
238             This software is copyright (c) 2006 by Infinity Interactive, Inc.
239              
240             This is free software; you can redistribute it and/or modify it under
241             the same terms as the Perl 5 programming language system itself.
242              
243             =cut