File Coverage

blib/lib/Method/Traits.pm
Criterion Covered Total %
statement 65 66 98.4
branch 16 22 72.7
condition 10 12 83.3
subroutine 11 11 100.0
pod 0 1 0.0
total 102 112 91.0


line stmt bran cond sub pod time code
1             package Method::Traits;
2             # ABSTRACT: Apply traits to your methods
3              
4 9     9   895784 use strict;
  9         159  
  9         328  
5 9     9   63 use warnings;
  9         22  
  9         519  
6              
7             our $VERSION = '0.08';
8             our $AUTHORITY = 'cpan:STEVAN';
9              
10 9     9   64 use Carp ();
  9         24  
  9         154  
11 9     9   55 use Scalar::Util ();
  9         21  
  9         187  
12 9     9   1866 use MOP (); # this is how we do most of our work
  9         293234  
  9         315  
13 9     9   71 use Module::Runtime (); # trait provider loading
  9         24  
  9         191  
14              
15             ## ...
16              
17 9     9   3381 use Method::Traits::Meta::Provider;
  9         24  
  9         5791  
18              
19             ## --------------------------------------------------------
20             ## Importers
21             ## --------------------------------------------------------
22              
23             sub import {
24 23     23   40830 my $class = shift;
25              
26 23 100       173 return unless @_;
27              
28 17         59 my @args = @_;
29 17 100 100     135 if ( scalar(@args) == 1 && $args[0] eq ':for_providers' ) {
30             # expand this to make it easier for providers
31 5         15 $args[0] = 'Method::Traits::Meta::Provider';
32             }
33              
34 17         74 $class->import_into( scalar caller, @args );
35             }
36              
37             ## --------------------------------------------------------
38             ## Trait collection
39             ## --------------------------------------------------------
40              
41             our %PROVIDERS_BY_PKG;
42              
43             sub import_into {
44 17     17 0 63 my (undef, $package, @providers) = @_;
45              
46 17 50       50 Carp::confess('You must provide a valid package argument')
47             unless $package;
48              
49 17 50       51 Carp::confess('The package argument cannot be a reference or blessed object')
50             if ref $package;
51              
52 17 50       47 Carp::confess('You must supply at least one provider')
53             unless scalar @providers;
54              
55             # conver this into a metaobject
56 17         134 my $meta = MOP::Role->new( $package );
57              
58             # load the providers, and then ...
59 17         1898 Module::Runtime::use_package_optimistically( $_ ) foreach @providers;
60              
61             # ... save the provider/package mapping
62 17   100     2367 push @{ $PROVIDERS_BY_PKG{ $meta->name } ||=[] } => @providers;
  17         75  
63              
64             # no need to install the collectors
65             # if they have already been installed
66             # as they are not different
67             return
68 17 100 66     585 if $meta->has_method_alias('FETCH_CODE_ATTRIBUTES')
69             && $meta->has_method_alias('MODIFY_CODE_ATTRIBUTES');
70              
71             # now install the collectors ...
72              
73 16         510 my %accepted; # shared state between these two methods ...
74              
75             $meta->alias_method(
76             FETCH_CODE_ATTRIBUTES => sub {
77 48     48   26061 my (undef, $code) = @_;
78             # return just the strings, as expected by attributes ...
79 48 100       163 return $accepted{ $code } ? @{ $accepted{ $code } } : ();
  45         582  
80             }
81 16         130 );
82             $meta->alias_method(
83             MODIFY_CODE_ATTRIBUTES => sub {
84 42     42   9478 my ($pkg, $code, @attrs) = @_;
85              
86 42   50     92 my @providers = @{ $PROVIDERS_BY_PKG{ $pkg } ||=[] }; # fetch complete set
  42         193  
87 42         234 my @attributes = map MOP::Method::Attribute->new( $_ ), @attrs;
88              
89 42         2541 my ( %attr_to_handler_map, @unhandled );
90 42         168 foreach my $attribute ( @attributes ) {
91 46         144 my $name = $attribute->name;
92 46   100     598 my $h; $h = $_->can( $name ) and last foreach @providers;
  46         410  
93 46 50       137 if ( $h ) {
94 46         135 $attr_to_handler_map{ $name } = $h;
95             }
96             else {
97 0         0 push @unhandled => $attribute->original;
98             }
99             }
100              
101             # return the bad traits as strings, as expected by attributes ...
102 42 50       115 return @unhandled if @unhandled;
103              
104 42         415 my $klass = MOP::Role->new( $pkg );
105 42         3076 my $method = MOP::Method->new( $code );
106              
107 42         2288 foreach my $attribute ( @attributes ) {
108 46         441 my ($name, $args) = ($attribute->name, $attribute->args);
109 46         1912 my $h = $attr_to_handler_map{ $name };
110              
111 46         183 $h->( $klass, $method, @$args );
112              
113 46 100       8453 if ( MOP::Method->new( $h )->has_code_attributes('OverwritesMethod') ) {
114 26         92 $method = $klass->get_method( $method->name );
115 26 50       5213 Carp::croak('Failed to find new overwriten method ('.$method->name.') in class ('.$meta->name.')')
116             unless defined $method;
117             }
118             }
119              
120             # store the traits we applied ...
121 42         2102 $accepted{ $method->body } = [ map $_->original, @attributes ];
122              
123 42         593 return;
124             }
125 16         963 );
126             }
127              
128             1;
129              
130             __END__