File Coverage

blib/lib/Sub/HandlesVia/Toolkit/Moose.pm
Criterion Covered Total %
statement 87 95 91.5
branch 25 34 73.5
condition 5 15 33.3
subroutine 20 21 95.2
pod 0 5 0.0
total 137 170 80.5


line stmt bran cond sub pod time code
1 22     22   420 use 5.008;
  22         78  
2 22     22   140 use strict;
  22         45  
  22         527  
3 22     22   106 use warnings;
  22         44  
  22         1426  
4              
5             package Sub::HandlesVia::Toolkit::Moose;
6              
7             our $AUTHORITY = 'cpan:TOBYINK';
8             our $VERSION = '0.046';
9              
10 22     22   10511 use Sub::HandlesVia::Mite;
  22         74  
  22         145  
11             extends 'Sub::HandlesVia::Toolkit';
12              
13             sub setup_for {
14 89     89 0 273 my $me = shift;
15 89         292 my ($target) = @_;
16            
17 89         505 require Moose::Util;
18 89         458 my $meta = Moose::Util::find_meta($target);
19 89         1467 $me->meta_hack( $meta );
20             }
21              
22             sub meta_hack {
23 92     92 0 341 my ( $me, $meta ) = ( shift, @_ );
24            
25 92         481 require Moose::Util::MetaRole;
26            
27 92 100       780 if ( $meta->isa('Moose::Meta::Role') ) {
28            
29 3         18 return Moose::Util::MetaRole::apply_metaroles(
30             for => $meta,
31             role_metaroles => { role => [ $me->package_trait, $me->role_trait ] },
32             );
33             }
34             else {
35            
36 89         490 return Moose::Util::MetaRole::apply_metaroles(
37             for => $meta,
38             class_metaroles => { class => [ $me->package_trait ] },
39             );
40             }
41             }
42              
43             sub package_trait {
44 93     93 0 2863 __PACKAGE__ . "::PackageTrait";
45             }
46              
47             sub role_trait {
48 4     4 0 33 __PACKAGE__ . "::RoleTrait";
49             }
50              
51             sub code_generator_for_attribute {
52 104     104 0 552 my ($me, $target, $attrname) = (shift, @_);
53            
54 104 50       505 if (ref $attrname) {
55 104 50       492 @$attrname==1 or die;
56 104         353 ($attrname) = @$attrname;
57             }
58            
59 104         287 my $meta;
60 104 50       465 if (ref $target) {
61 0         0 $meta = $target;
62 0         0 $target = $meta->name;
63             }
64             else {
65 104         809 require Moose::Util;
66 104         575 $meta = Moose::Util::find_meta($target);
67             }
68              
69 104         2443 my $attr = $meta->get_attribute($attrname);
70 104         2048 my $spec = +{%$attr};
71              
72 104         409 my $captures = {};
73            
74             my $slot = sub {
75 1542     1542   2627 my $gen = shift;
76 1542         5695 $meta->get_meta_instance->inline_slot_access($gen->generate_self, $attrname);
77 104         756 };
78            
79 104         372 my ($get, $set, $get_is_lvalue, $set_checks_isa);
80 104 100 33     1299 if (!$spec->{lazy} and !$spec->{traits} and !$spec->{auto_deref}) {
    100          
81 80         243 $get = $slot;
82 80         218 ++$get_is_lvalue;
83             }
84             elsif ($attr->has_read_method) {
85 18         506 my $read_method = $attr->get_read_method;
86 18     294   330 $get = sub { my $self = shift->generate_self; "scalar($self\->$read_method)" };
  294         788  
  294         2060  
87             }
88             else {
89 6         81 my $read_method = $attr->get_read_method_ref;
90 6         664 eval { $read_method = $read_method->{body} }; # Moose docs lie!
  6         36  
91 6         20 $captures->{'$shv_read_method'} = \$read_method;
92 6     12   31 $get = sub { my $self = shift->generate_self; "scalar($self\->\$shv_read_method)" };
  12         39  
  12         77  
93             }
94            
95 104 100       752 if ($attr->has_write_method) {
96 76         1306 my $write_method = $attr->get_write_method;
97             $set = sub {
98 777     777   2892 my ($gen, $val) = @_;
99 777         2128 my $self = $gen->generate_self;
100 777         4460 "$self\->$write_method\($val)"
101 76         1296 };
102 76         269 ++$set_checks_isa;
103             }
104             else {
105             $captures->{'$shv_write_method'} = \(
106             $attr->can('set_value')
107 30     30   250407 ? sub { $attr->set_value(@_) }
108 0     0   0 : sub { my ($instance, $value) = @_; $instance->meta->get_attribute($attrname)->set_value($instance, $value) }
  0         0  
109 28 50       549 );
110             $set = sub {
111 13     13   74 my ($gen, $val) = @_;
112 13         46 my $self = $gen->generate_self;
113 13         82 $self.'->$shv_write_method('.$val.')';
114 28         140 };
115 28         67 ++$set_checks_isa;
116             }
117              
118 104         271 my $default;
119 104 100       513 if (exists $spec->{default}) {
    100          
120 81         330 $default = [ default => $spec->{default} ];
121             }
122             elsif (exists $spec->{builder}) {
123 9         43 $default = [ builder => $spec->{builder} ];
124             }
125              
126 104 100       486 if (ref $default->[1] eq 'CODE') {
127 37         148 $captures->{'$shv_default_for_reset'} = \$default->[1];
128             }
129              
130 104         13532 require Sub::HandlesVia::CodeGenerator;
131             return 'Sub::HandlesVia::CodeGenerator'->new(
132             toolkit => $me,
133             target => $target,
134             attribute => $attrname,
135             attribute_spec => $spec,
136             env => $captures,
137             isa => Types::TypeTiny::to_TypeTiny($attr->type_constraint),
138             coerce => !!$spec->{coerce},
139             generator_for_slot => $slot,
140             generator_for_get => $get,
141             generator_for_set => $set,
142             get_is_lvalue => $get_is_lvalue,
143             set_checks_isa => $set_checks_isa,
144             set_strictly => !!1,
145 1295     1295   5474 method_installer => sub { $meta->add_method(@_) },
146             generator_for_default => sub {
147 15 50   15   79 my ( $gen, $handler ) = @_ or die;
148 15 50 33     199 if ( !$default and $handler ) {
    100 33        
    50 33        
    50 33        
    50          
149 0         0 return $handler->default_for_reset->();
150             }
151             elsif ( $default->[0] eq 'builder' ) {
152 4         13 return sprintf(
153             '(%s)->%s',
154             $gen->generate_self,
155             $default->[1],
156             );
157             }
158             elsif ( $default->[0] eq 'default' and ref $default->[1] eq 'CODE' ) {
159 0         0 return sprintf(
160             '(%s)->$shv_default_for_reset',
161             $gen->generate_self,
162             );
163             }
164             elsif ( $default->[0] eq 'default' and !defined $default->[1] ) {
165 0         0 return 'undef';
166             }
167             elsif ( $default->[0] eq 'default' and !ref $default->[1] ) {
168 11         72 require B;
169 11         78 return B::perlstring( $default->[1] );
170             }
171 0         0 return;
172             },
173 104         4816 );
174             }
175              
176             package Sub::HandlesVia::Toolkit::Moose::PackageTrait;
177              
178             our $AUTHORITY = 'cpan:TOBYINK';
179             our $VERSION = '0.046';
180              
181 22     22   39216 use Moose::Role;
  22         97111  
  22         192  
182              
183             sub _shv_toolkit {
184 213     213   1537 'Sub::HandlesVia::Toolkit::Moose',
185             }
186              
187             around add_attribute => sub {
188             my ($next, $self, @args) = (shift, shift, @_);
189             my ($spec, $attrobj, $attrname);
190             if (@args == 1) {
191             $spec = $attrobj = $_[0];
192             $attrname = $attrobj->name;
193             }
194             elsif (@args == 2) {
195             ($attrname, $spec) = @args;
196             }
197             else {
198             my %spec;
199             ($attrname, %spec) = @args;
200             $spec = \%spec;
201             }
202             ( my $real_attrname = $attrname ) =~ s/^[+]//;
203             $spec->{definition_context}{shv} = $self->_shv_toolkit->clean_spec($self->name, $real_attrname, $spec)
204             unless $spec->{definition_context}{shv};
205             my $attr = $self->$next($attrobj ? $attrobj : ($attrname, %$spec));
206             if ($spec->{definition_context}{shv} and $self->isa('Moose::Meta::Class')) {
207             $self->_shv_toolkit->install_delegations(+{
208             %{ $spec->{definition_context}{shv} },
209             target => $self->name,
210             });
211             }
212             return $attr;
213             };
214              
215             package Sub::HandlesVia::Toolkit::Moose::RoleTrait;
216              
217             our $AUTHORITY = 'cpan:TOBYINK';
218             our $VERSION = '0.046';
219              
220 22     22   146355 use Moose::Role;
  22         85  
  22         469  
221             requires '_shv_toolkit';
222              
223             around apply => sub {
224             my ($next, $self, $other, %args) = (shift, shift, @_);
225             $other = $self->_shv_toolkit->meta_hack( $other );
226             $self->$next( $other, %args );
227             };
228              
229             around composition_class_roles => sub {
230             my ( $next, $self ) = ( shift, shift );
231             my @return = $self->$next( @_ );
232             return (
233             @return,
234             $self->_shv_toolkit->package_trait,
235             $self->_shv_toolkit->role_trait,
236             );
237             };
238              
239             1;