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