File Coverage

blib/lib/Moose/Meta/Method/Accessor/Native.pm
Criterion Covered Total %
statement 46 46 100.0
branch 7 8 87.5
condition 2 3 66.6
subroutine 16 16 100.0
pod 0 1 0.0
total 71 74 95.9


line stmt bran cond sub pod time code
1             package Moose::Meta::Method::Accessor::Native;
2             our $VERSION = '2.2206';
3              
4 48     48   27429 use strict;
  48         146  
  48         1651  
5 48     48   286 use warnings;
  48         126  
  48         1477  
6              
7 48     48   281 use Carp qw( confess );
  48         125  
  48         3286  
8 48     48   378 use Scalar::Util qw( blessed );
  48         118  
  48         2233  
9              
10 48     48   300 use Moose::Role;
  48         129  
  48         326  
11              
12 48     48   402 use Moose::Util 'throw_exception';
  48         170  
  48         434  
13              
14             around new => sub {
15             my $orig = shift;
16             my $class = shift;
17             my %options = @_;
18              
19             $options{curried_arguments} = []
20             unless exists $options{curried_arguments};
21              
22             throw_exception( MustSupplyArrayRefAsCurriedArguments => params => \%options,
23             class_name => $class
24             )
25             unless $options{curried_arguments}
26             && ref($options{curried_arguments}) eq 'ARRAY';
27              
28             my $attr_context = $options{attribute}->definition_context;
29             my $desc = 'native delegation method ';
30             $desc .= $options{attribute}->associated_class->name;
31             $desc .= '::' . $options{name};
32             $desc .= " ($options{delegate_to_method})";
33             $desc .= " of attribute " . $options{attribute}->name;
34             $options{definition_context} = {
35             %{ $attr_context || {} },
36             description => $desc,
37             };
38              
39             $options{accessor_type} = 'native';
40              
41             return $class->$orig(%options);
42             };
43              
44             sub _new {
45 1032     1032   2112 my $class = shift;
46 1032 50       2804 my $options = @_ == 1 ? $_[0] : {@_};
47              
48 1032         2994 return bless $options, $class;
49             }
50              
51 1699     1699 0 6459 sub root_types { (shift)->{'root_types'} }
52              
53             sub _initialize_body {
54 1032     1032   1845 my $self = shift;
55              
56 1032         4316 $self->{'body'} = $self->_compile_code( [$self->_generate_method] );
57              
58 1032         782006 return;
59             }
60              
61             sub _inline_curried_arguments {
62 1032     1032   1935 my $self = shift;
63              
64 1032 100       1660 return unless @{ $self->curried_arguments };
  1032         4674  
65              
66 273         1086 return 'unshift @_, @curried;';
67             }
68              
69             sub _inline_check_argument_count {
70 1094     1094   1860 my $self = shift;
71              
72 1094         1773 my @code;
73              
74 1094 100       4080 if (my $min = $self->_minimum_arguments) {
75 623         2740 push @code, (
76             'if (@_ < ' . $min . ') {',
77             $self->_inline_throw_exception( MethodExpectsMoreArgs =>
78             'method_name => "'.$self->delegate_to_method.'",'.
79             "minimum_args => ".$min,
80             ) . ';',
81             '}',
82             );
83             }
84              
85 1094 100       5115 if (defined(my $max = $self->_maximum_arguments)) {
86 895         3993 push @code, (
87             'if (@_ > ' . $max . ') {',
88             $self->_inline_throw_exception( MethodExpectsFewerArgs =>
89             'method_name => "'.$self->delegate_to_method.'",'.
90             'maximum_args => '.$max,
91             ) . ';',
92             '}',
93             );
94             }
95              
96 1094         6028 return @code;
97             }
98              
99             sub _inline_return_value {
100 1057     1057   2165 my $self = shift;
101 1057         2373 my ($slot_access, $for_writer) = @_;
102              
103 1057         4388 return 'return ' . $self->_return_value($slot_access, $for_writer) . ';';
104             }
105              
106 433     433   1414 sub _minimum_arguments { 0 }
107 179     179   598 sub _maximum_arguments { undef }
108              
109             override _get_value => sub {
110             my $self = shift;
111             my ($instance) = @_;
112              
113             return $self->_slot_access_can_be_inlined
114             ? super()
115             : $instance . '->$reader';
116             };
117              
118             override _inline_store_value => sub {
119             my $self = shift;
120             my ($instance, $value) = @_;
121              
122             return $self->_slot_access_can_be_inlined
123             ? super()
124             : $instance . '->$writer(' . $value . ');';
125             };
126              
127             override _eval_environment => sub {
128             my $self = shift;
129              
130             my $env = super();
131              
132             $env->{'@curried'} = $self->curried_arguments;
133              
134             return $env if $self->_slot_access_can_be_inlined;
135              
136             my $reader = $self->associated_attribute->get_read_method_ref;
137             $reader = $reader->body if blessed $reader;
138              
139             $env->{'$reader'} = \$reader;
140              
141             my $writer = $self->associated_attribute->get_write_method_ref;
142             $writer = $writer->body if blessed $writer;
143              
144             $env->{'$writer'} = \$writer;
145              
146             return $env;
147             };
148              
149             sub _slot_access_can_be_inlined {
150 2840     2840   4649 my $self = shift;
151              
152 2840   66     14093 return $self->is_inline && $self->_instance_is_inlinable;
153             }
154              
155 48     48   54970 no Moose::Role;
  48         157  
  48         300  
156              
157             1;