Commit | Line | Data |
f7fd22b6 |
1 | package Moose::Meta::Method::Accessor::Native; |
2 | |
3 | use strict; |
4 | use warnings; |
5 | |
6 | use Carp qw( confess ); |
7 | use Scalar::Util qw( blessed weaken ); |
8 | |
245478d5 |
9 | our $VERSION = '1.19'; |
f7fd22b6 |
10 | $VERSION = eval $VERSION; |
11 | our $AUTHORITY = 'cpan:STEVAN'; |
12 | |
8b9641b8 |
13 | use Moose::Role; |
f7fd22b6 |
14 | |
8b9641b8 |
15 | around new => sub { |
16 | my $orig = shift; |
f7fd22b6 |
17 | my $class = shift; |
18 | my %options = @_; |
19 | |
1e2c801e |
20 | $options{curried_arguments} = [] |
21 | unless exists $options{curried_arguments}; |
f7fd22b6 |
22 | |
1e2c801e |
23 | confess 'You must supply a curried_arguments which is an ARRAY reference' |
24 | unless $options{curried_arguments} |
25 | && ref($options{curried_arguments}) eq 'ARRAY'; |
f7fd22b6 |
26 | |
f5f08b5f |
27 | $options{definition_context} = $options{attribute}->definition_context; |
28 | |
8b9641b8 |
29 | $options{accessor_type} = 'native'; |
f7fd22b6 |
30 | |
8b9641b8 |
31 | return $class->$orig(%options); |
32 | }; |
f7fd22b6 |
33 | |
53a4677c |
34 | sub _new { |
f7fd22b6 |
35 | my $class = shift; |
36 | my $options = @_ == 1 ? $_[0] : {@_}; |
37 | |
38 | return bless $options, $class; |
53a4677c |
39 | } |
f7fd22b6 |
40 | |
a6ae7438 |
41 | sub root_types { (shift)->{'root_types'} } |
42 | |
f7fd22b6 |
43 | sub _initialize_body { |
44 | my $self = shift; |
45 | |
53a4677c |
46 | $self->{'body'} = $self->_compile_code( [$self->_generate_method] ); |
f7fd22b6 |
47 | |
48 | return; |
49 | } |
50 | |
855f4af8 |
51 | sub _inline_curried_arguments { |
52 | my $self = shift; |
53 | |
53a4677c |
54 | return unless @{ $self->curried_arguments }; |
855f4af8 |
55 | |
1e2c801e |
56 | return 'unshift @_, @curried;'; |
855f4af8 |
57 | } |
58 | |
59 | sub _inline_check_argument_count { |
60 | my $self = shift; |
61 | |
53a4677c |
62 | my @code; |
63 | |
64 | if (my $min = $self->_minimum_arguments) { |
65 | push @code, ( |
66 | 'if (@_ < ' . $min . ') {', |
67 | $self->_inline_throw_error( |
68 | sprintf( |
69 | '"Cannot call %s without at least %s argument%s"', |
70 | $self->delegate_to_method, |
71 | $min, |
72 | ($min == 1 ? '' : 's'), |
73 | ) |
74 | ) . ';', |
75 | '}', |
855f4af8 |
76 | ); |
855f4af8 |
77 | } |
78 | |
53a4677c |
79 | if (defined(my $max = $self->_maximum_arguments)) { |
80 | push @code, ( |
81 | 'if (@_ > ' . $max . ') {', |
82 | $self->_inline_throw_error( |
83 | sprintf( |
84 | '"Cannot call %s with %s argument%s"', |
85 | $self->delegate_to_method, |
86 | $max ? "more than $max" : 'any', |
87 | ($max == 1 ? '' : 's'), |
88 | ) |
89 | ) . ';', |
90 | '}', |
855f4af8 |
91 | ); |
855f4af8 |
92 | } |
93 | |
53a4677c |
94 | return @code; |
95 | } |
96 | |
97 | sub _inline_return_value { |
98 | my $self = shift; |
99 | my ($slot_access, $for_writer) = @_; |
100 | |
1e2c801e |
101 | return 'return ' . $self->_return_value($slot_access, $for_writer) . ';'; |
855f4af8 |
102 | } |
103 | |
104 | sub _minimum_arguments { 0 } |
105 | sub _maximum_arguments { undef } |
106 | |
1e2c801e |
107 | override _get_value => sub { |
53a4677c |
108 | my $self = shift; |
109 | my ($instance) = @_; |
54e259f6 |
110 | |
111 | return $self->_slot_access_can_be_inlined |
8b9641b8 |
112 | ? super() |
53a4677c |
113 | : $instance . '->$reader'; |
8b9641b8 |
114 | }; |
54e259f6 |
115 | |
a486d5ad |
116 | override _inline_store_value => sub { |
53a4677c |
117 | my $self = shift; |
118 | my ($instance, $value) = @_; |
54e259f6 |
119 | |
120 | return $self->_slot_access_can_be_inlined |
8b9641b8 |
121 | ? super() |
a486d5ad |
122 | : $instance . '->$writer(' . $value . ');'; |
8b9641b8 |
123 | }; |
54e259f6 |
124 | |
8b9641b8 |
125 | override _eval_environment => sub { |
54e259f6 |
126 | my $self = shift; |
127 | |
8b9641b8 |
128 | my $env = super(); |
54e259f6 |
129 | |
130 | $env->{'@curried'} = $self->curried_arguments; |
131 | |
132 | return $env if $self->_slot_access_can_be_inlined; |
133 | |
134 | my $reader = $self->associated_attribute->get_read_method_ref; |
135 | $reader = $reader->body if blessed $reader; |
136 | |
137 | $env->{'$reader'} = \$reader; |
138 | |
139 | my $writer = $self->associated_attribute->get_write_method_ref; |
140 | $writer = $writer->body if blessed $writer; |
141 | |
142 | $env->{'$writer'} = \$writer; |
143 | |
144 | return $env; |
8b9641b8 |
145 | }; |
54e259f6 |
146 | |
147 | sub _slot_access_can_be_inlined { |
148 | my $self = shift; |
149 | |
150 | return $self->is_inline && $self->_instance_is_inlinable; |
151 | } |
152 | |
8b9641b8 |
153 | no Moose::Role; |
154 | |
f7fd22b6 |
155 | 1; |