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 | |
10bd99ec |
9 | our $VERSION = '1.14'; |
f7fd22b6 |
10 | $VERSION = eval $VERSION; |
11 | our $AUTHORITY = 'cpan:STEVAN'; |
12 | |
13 | use base 'Moose::Meta::Method::Accessor', 'Moose::Meta::Method::Delegation'; |
14 | |
15 | sub new { |
16 | my $class = shift; |
17 | my %options = @_; |
18 | |
19 | die "Cannot instantiate a $class object directly" |
20 | if $class eq __PACKAGE__; |
21 | |
22 | ( exists $options{attribute} ) |
23 | || confess "You must supply an attribute to construct with"; |
24 | |
25 | ( blessed( $options{attribute} ) |
26 | && $options{attribute}->isa('Class::MOP::Attribute') ) |
27 | || confess |
28 | "You must supply an attribute which is a 'Class::MOP::Attribute' instance"; |
29 | |
30 | ( $options{package_name} && $options{name} ) |
31 | || confess "You must supply the package_name and name parameters"; |
32 | |
33 | exists $options{curried_arguments} |
34 | || ( $options{curried_arguments} = [] ); |
35 | |
36 | ( $options{curried_arguments} |
37 | && ( 'ARRAY' eq ref $options{curried_arguments} ) ) |
38 | || confess |
39 | 'You must supply a curried_arguments which is an ARRAY reference'; |
40 | |
41 | $options{delegate_to_method} = lc( ( split /::/, $class)[-1] ); |
42 | |
f5f08b5f |
43 | $options{definition_context} = $options{attribute}->definition_context; |
44 | |
f7fd22b6 |
45 | my $self = $class->_new( \%options ); |
46 | |
47 | weaken( $self->{'attribute'} ); |
48 | |
49 | $self->_initialize_body; |
50 | |
51 | return $self; |
52 | } |
53 | |
54 | sub _new { |
55 | my $class = shift; |
56 | my $options = @_ == 1 ? $_[0] : {@_}; |
57 | |
58 | return bless $options, $class; |
59 | } |
60 | |
a6ae7438 |
61 | sub root_types { (shift)->{'root_types'} } |
62 | |
f7fd22b6 |
63 | sub _initialize_body { |
64 | my $self = shift; |
65 | |
66 | $self->{'body'} = $self->_eval_code( $self->_generate_method ); |
67 | |
68 | return; |
69 | } |
70 | |
855f4af8 |
71 | sub _inline_curried_arguments { |
72 | my $self = shift; |
73 | |
74 | return q{} unless @{ $self->curried_arguments }; |
75 | |
76 | return 'unshift @_, @curried;' |
77 | } |
78 | |
79 | sub _inline_check_argument_count { |
80 | my $self = shift; |
81 | |
82 | my $code = q{}; |
83 | |
84 | if ( my $min = $self->_minimum_arguments ) { |
85 | my $err_msg = sprintf( |
86 | q{"Cannot call %s without at least %s argument%s"}, |
87 | $self->delegate_to_method, |
88 | $min, |
89 | ( $min == 1 ? q{} : 's' ) |
90 | ); |
91 | |
92 | $code |
93 | .= "\n" |
94 | . $self->_inline_throw_error($err_msg) |
95 | . " unless \@_ >= $min;"; |
96 | } |
97 | |
98 | if ( defined( my $max = $self->_maximum_arguments ) ) { |
99 | my $err_msg = sprintf( |
100 | q{"Cannot call %s with %s argument%s"}, |
101 | $self->delegate_to_method, |
102 | ( $max ? "more than $max" : 'any' ), |
103 | ( $max == 1 ? q{} : 's' ) |
104 | ); |
105 | |
106 | $code |
107 | .= "\n" |
108 | . $self->_inline_throw_error($err_msg) |
109 | . " if \@_ > $max;"; |
110 | } |
111 | |
112 | return $code; |
113 | } |
114 | |
115 | sub _minimum_arguments { 0 } |
116 | sub _maximum_arguments { undef } |
117 | |
118 | sub _inline_check_arguments { q{} } |
119 | |
54e259f6 |
120 | sub _inline_get { |
121 | my ( $self, $instance ) = @_; |
122 | |
123 | return $self->_slot_access_can_be_inlined |
124 | ? $self->SUPER::_inline_get($instance) |
125 | : "${instance}->\$reader"; |
126 | } |
127 | |
128 | sub _inline_store { |
129 | my ( $self, $instance, $value ) = @_; |
130 | |
131 | return $self->_slot_access_can_be_inlined |
132 | ? $self->SUPER::_inline_store( $instance, $value ) |
133 | : "${instance}->\$writer($value)"; |
134 | } |
135 | |
136 | sub _eval_environment { |
137 | my $self = shift; |
138 | |
139 | my $env = $self->SUPER::_eval_environment(@_); |
140 | |
141 | $env->{'@curried'} = $self->curried_arguments; |
142 | |
143 | return $env if $self->_slot_access_can_be_inlined; |
144 | |
145 | my $reader = $self->associated_attribute->get_read_method_ref; |
146 | $reader = $reader->body if blessed $reader; |
147 | |
148 | $env->{'$reader'} = \$reader; |
149 | |
150 | my $writer = $self->associated_attribute->get_write_method_ref; |
151 | $writer = $writer->body if blessed $writer; |
152 | |
153 | $env->{'$writer'} = \$writer; |
154 | |
155 | return $env; |
156 | } |
157 | |
158 | sub _slot_access_can_be_inlined { |
159 | my $self = shift; |
160 | |
161 | return $self->is_inline && $self->_instance_is_inlinable; |
162 | } |
163 | |
f7fd22b6 |
164 | 1; |