Commit | Line | Data |
8ee73eeb |
1 | |
2 | package Moose::Meta::Method::Accessor; |
3 | |
4 | use strict; |
5 | use warnings; |
6 | |
55c361dc |
7 | use Try::Tiny; |
8 | |
39b3bc94 |
9 | use base 'Moose::Meta::Method', |
d617b644 |
10 | 'Class::MOP::Method::Accessor'; |
11 | |
aa5bb362 |
12 | # multiple inheritance is terrible |
13 | sub new { |
14 | goto &Class::MOP::Method::Accessor::new; |
15 | } |
16 | |
17 | sub _new { |
18 | goto &Class::MOP::Method::Accessor::_new; |
19 | } |
20 | |
18748ad6 |
21 | sub _error_thrower { |
22 | my $self = shift; |
cc743de9 |
23 | return $self->associated_attribute |
24 | if ref($self) && defined($self->associated_attribute); |
25 | return $self->SUPER::_error_thrower; |
18748ad6 |
26 | } |
d617b644 |
27 | |
55c361dc |
28 | sub _compile_code { |
29 | my $self = shift; |
30 | my @args = @_; |
31 | try { |
32 | $self->SUPER::_compile_code(@args); |
33 | } |
34 | catch { |
35 | $self->throw_error( |
36 | 'Could not create writer for ' |
37 | . "'" . $self->associated_attribute->name . "' " |
38 | . 'because ' . $_, |
39 | error => $_, |
40 | ); |
41 | }; |
c9183ffc |
42 | } |
43 | |
f5f08b5f |
44 | sub _eval_environment { |
45 | my $self = shift; |
46 | |
144a8df1 |
47 | my $env = { }; |
48 | |
49 | my $attr = $self->associated_attribute; |
50 | |
51 | $env->{'$trigger'} = \($attr->trigger) |
52 | if $attr->has_trigger; |
0ec49767 |
53 | $env->{'$attr_default'} = \($attr->default) |
144a8df1 |
54 | if $attr->has_default; |
55 | |
56 | if ($attr->has_type_constraint) { |
57 | my $tc_obj = $attr->type_constraint; |
58 | |
c40e4359 |
59 | $env->{'$type_constraint'} = \( |
60 | $tc_obj->_compiled_type_constraint |
61 | ) unless $tc_obj->can_be_inlined; |
a619fc2f |
62 | # these two could probably get inlined versions too |
c40e4359 |
63 | $env->{'$type_coercion'} = \( |
64 | $tc_obj->coercion->_compiled_type_coercion |
65 | ) if $tc_obj->has_coercion; |
a619fc2f |
66 | $env->{'$type_message'} = \( |
67 | $tc_obj->has_message ? $tc_obj->message : $tc_obj->_default_message |
68 | ); |
144a8df1 |
69 | |
70 | $env = { %$env, %{ $tc_obj->inline_environment } }; |
71 | } |
72 | |
73 | # XXX ugh, fix these |
74 | $env->{'$attr'} = \$attr |
d1ef0daf |
75 | if $attr->has_initializer && $attr->is_lazy; |
bcc04ae1 |
76 | # pretty sure this is only going to be closed over if you use a custom |
77 | # error class at this point, but we should still get rid of this |
78 | # at some point |
79 | $env->{'$meta'} = \($self->associated_metaclass); |
144a8df1 |
80 | |
81 | return $env; |
f5f08b5f |
82 | } |
83 | |
f001c60f |
84 | sub _instance_is_inlinable { |
85 | my $self = shift; |
86 | return $self->associated_attribute->associated_class->instance_metaclass->is_inlinable; |
87 | } |
88 | |
89 | sub _generate_reader_method { |
90 | my $self = shift; |
91 | $self->_instance_is_inlinable ? $self->_generate_reader_method_inline(@_) |
92 | : $self->SUPER::_generate_reader_method(@_); |
93 | } |
94 | |
95 | sub _generate_writer_method { |
96 | my $self = shift; |
97 | $self->_instance_is_inlinable ? $self->_generate_writer_method_inline(@_) |
98 | : $self->SUPER::_generate_writer_method(@_); |
99 | } |
100 | |
101 | sub _generate_accessor_method { |
102 | my $self = shift; |
103 | $self->_instance_is_inlinable ? $self->_generate_accessor_method_inline(@_) |
104 | : $self->SUPER::_generate_accessor_method(@_); |
105 | } |
106 | |
107 | sub _generate_predicate_method { |
108 | my $self = shift; |
109 | $self->_instance_is_inlinable ? $self->_generate_predicate_method_inline(@_) |
110 | : $self->SUPER::_generate_predicate_method(@_); |
111 | } |
112 | |
113 | sub _generate_clearer_method { |
114 | my $self = shift; |
115 | $self->_instance_is_inlinable ? $self->_generate_clearer_method_inline(@_) |
116 | : $self->SUPER::_generate_clearer_method(@_); |
117 | } |
8ecb1fa0 |
118 | |
6e50f7e9 |
119 | sub _writer_value_needs_copy { |
120 | shift->associated_attribute->_writer_value_needs_copy(@_); |
121 | } |
c350159f |
122 | |
1e2c801e |
123 | sub _inline_tc_code { |
6e50f7e9 |
124 | shift->associated_attribute->_inline_tc_code(@_); |
1e2c801e |
125 | } |
126 | |
0f4afc62 |
127 | sub _inline_check_coercion { |
128 | shift->associated_attribute->_inline_check_coercion(@_); |
129 | } |
130 | |
d617b644 |
131 | sub _inline_check_constraint { |
6e50f7e9 |
132 | shift->associated_attribute->_inline_check_constraint(@_); |
d617b644 |
133 | } |
134 | |
135 | sub _inline_check_lazy { |
6e50f7e9 |
136 | shift->associated_attribute->_inline_check_lazy(@_); |
9df136d0 |
137 | } |
d617b644 |
138 | |
1e2c801e |
139 | sub _inline_store_value { |
6e50f7e9 |
140 | shift->associated_attribute->_inline_instance_set(@_) . ';'; |
d617b644 |
141 | } |
142 | |
3dda07f5 |
143 | sub _inline_get_old_value_for_trigger { |
6e50f7e9 |
144 | shift->associated_attribute->_inline_get_old_value_for_trigger(@_); |
3dda07f5 |
145 | } |
146 | |
d617b644 |
147 | sub _inline_trigger { |
6e50f7e9 |
148 | shift->associated_attribute->_inline_trigger(@_); |
d617b644 |
149 | } |
150 | |
1e2c801e |
151 | sub _get_value { |
6e50f7e9 |
152 | shift->associated_attribute->_inline_instance_get(@_); |
d617b644 |
153 | } |
154 | |
1e2c801e |
155 | sub _has_value { |
6e50f7e9 |
156 | shift->associated_attribute->_inline_instance_has(@_); |
d617b644 |
157 | } |
8ee73eeb |
158 | |
159 | 1; |
160 | |
ad46f524 |
161 | # ABSTRACT: A Moose Method metaclass for accessors |
162 | |
8ee73eeb |
163 | __END__ |
164 | |
165 | =pod |
166 | |
39b3bc94 |
167 | =head1 DESCRIPTION |
168 | |
ba4dfb8e |
169 | This class is a subclass of L<Class::MOP::Method::Accessor> that |
73f769fc |
170 | provides additional Moose-specific functionality, all of which is |
171 | private. |
ecb59493 |
172 | |
73f769fc |
173 | To understand this class, you should read the the |
ba4dfb8e |
174 | L<Class::MOP::Method::Accessor> documentation. |
39b3bc94 |
175 | |
176 | =head1 BUGS |
177 | |
d4048ef3 |
178 | See L<Moose/BUGS> for details on reporting bugs. |
39b3bc94 |
179 | |
51308c23 |
180 | =cut |