Commit | Line | Data |
c0e30cf5 |
1 | |
2 | package Moose::Meta::Attribute; |
3 | |
4 | use strict; |
5 | use warnings; |
6 | |
78cd1d3b |
7 | use Scalar::Util 'blessed', 'weaken', 'reftype'; |
a15dff8d |
8 | use Carp 'confess'; |
9 | |
78cd1d3b |
10 | our $VERSION = '0.03'; |
11 | |
12 | use Moose::Util::TypeConstraints '-no-export'; |
bc1e29b5 |
13 | |
c0e30cf5 |
14 | use base 'Class::MOP::Attribute'; |
15 | |
ca01a97b |
16 | __PACKAGE__->meta->add_attribute('required' => (reader => 'is_required' )); |
17 | __PACKAGE__->meta->add_attribute('lazy' => (reader => 'is_lazy' )); |
6ba6d68c |
18 | __PACKAGE__->meta->add_attribute('coerce' => (reader => 'should_coerce')); |
19 | __PACKAGE__->meta->add_attribute('weak_ref' => (reader => 'is_weak_ref' )); |
82168dbb |
20 | __PACKAGE__->meta->add_attribute('type_constraint' => ( |
21 | reader => 'type_constraint', |
22 | predicate => 'has_type_constraint', |
23 | )); |
24 | |
78cd1d3b |
25 | sub new { |
26 | my ($class, $name, %options) = @_; |
27 | |
28 | if (exists $options{is}) { |
29 | if ($options{is} eq 'ro') { |
30 | $options{reader} = $name; |
31 | } |
32 | elsif ($options{is} eq 'rw') { |
33 | $options{accessor} = $name; |
34 | } |
35 | } |
36 | |
37 | if (exists $options{isa}) { |
38 | # allow for anon-subtypes here ... |
39 | if (blessed($options{isa}) && $options{isa}->isa('Moose::Meta::TypeConstraint')) { |
40 | $options{type_constraint} = $options{isa}; |
41 | } |
42 | else { |
43 | # otherwise assume it is a constraint |
44 | my $constraint = Moose::Util::TypeConstraints::find_type_constraint($options{isa}); |
45 | # if the constraing it not found .... |
46 | unless (defined $constraint) { |
47 | # assume it is a foreign class, and make |
48 | # an anon constraint for it |
49 | $constraint = Moose::Util::TypeConstraints::subtype( |
50 | 'Object', |
51 | Moose::Util::TypeConstraints::where { $_->isa($options{isa}) } |
52 | ); |
53 | } |
54 | $options{type_constraint} = $constraint; |
55 | } |
56 | } |
57 | |
4b598ea3 |
58 | if (exists $options{coerce} && $options{coerce}) { |
59 | (exists $options{type_constraint}) |
60 | || confess "You cannot have coercion without specifying a type constraint"; |
61 | confess "You cannot have a weak reference to a coerced value" |
62 | if $options{weak_ref}; |
ca01a97b |
63 | } |
78cd1d3b |
64 | |
ca01a97b |
65 | if (exists $options{lazy} && $options{lazy}) { |
66 | (exists $options{default}) |
67 | || confess "You cannot have lazy attribute without specifying a default value for it"; |
78cd1d3b |
68 | } |
69 | |
70 | $class->SUPER::new($name, %options); |
71 | } |
c0e30cf5 |
72 | |
a15dff8d |
73 | sub generate_accessor_method { |
74 | my ($self, $attr_name) = @_; |
ca01a97b |
75 | my $value_name = $self->should_coerce ? '$val' : '$_[1]'; |
76 | my $code = 'sub { ' |
77 | . 'if (scalar(@_) == 2) {' |
78 | . ($self->is_required ? |
79 | 'defined($_[1]) || confess "Attribute ($attr_name) is required, so cannot be set to undef";' |
80 | : '') |
81 | . ($self->should_coerce ? |
82 | 'my $val = $self->type_constraint->coercion->coerce($_[1]);' |
83 | : '') |
84 | . ($self->has_type_constraint ? |
85 | ('(defined $self->type_constraint->check(' . $value_name . '))' |
86 | . '|| confess "Attribute ($attr_name) does not pass the type contraint with \'' . $value_name . '\'"' |
87 | . 'if defined ' . $value_name . ';') |
88 | : '') |
89 | . '$_[0]->{$attr_name} = ' . $value_name . ';' |
90 | . ($self->is_weak_ref ? |
91 | 'weaken($_[0]->{$attr_name});' |
92 | : '') |
93 | . ' }' |
94 | . ($self->is_lazy ? |
95 | '$_[0]->{$attr_name} = ($self->has_default ? $self->default($_[0]) : undef)' |
96 | . 'unless exists $_[0]->{$attr_name};' |
97 | : '') |
98 | . ' $_[0]->{$attr_name};' |
99 | . ' }'; |
100 | my $sub = eval $code; |
101 | confess "Could not create writer for '$attr_name' because $@ \n code: $code" if $@; |
102 | return $sub; |
a15dff8d |
103 | } |
104 | |
105 | sub generate_writer_method { |
106 | my ($self, $attr_name) = @_; |
ca01a97b |
107 | my $value_name = $self->should_coerce ? '$val' : '$_[1]'; |
108 | my $code = 'sub { ' |
109 | . ($self->is_required ? |
110 | 'defined($_[1]) || confess "Attribute ($attr_name) is required, so cannot be set to undef";' |
111 | : '') |
112 | . ($self->should_coerce ? |
113 | 'my $val = $self->type_constraint->coercion->coerce($_[1]);' |
114 | : '') |
115 | . ($self->has_type_constraint ? |
116 | ('(defined $self->type_constraint->check(' . $value_name . '))' |
117 | . '|| confess "Attribute ($attr_name) does not pass the type contraint with \'' . $value_name . '\'"' |
118 | . 'if defined ' . $value_name . ';') |
119 | : '') |
120 | . '$_[0]->{$attr_name} = ' . $value_name . ';' |
121 | . ($self->is_weak_ref ? |
122 | 'weaken($_[0]->{$attr_name});' |
123 | : '') |
124 | . ' }'; |
125 | my $sub = eval $code; |
126 | confess "Could not create writer for '$attr_name' because $@ \n code: $code" if $@; |
127 | return $sub; |
a15dff8d |
128 | } |
c0e30cf5 |
129 | |
d7f17ebb |
130 | sub generate_reader_method { |
131 | my ($self, $attr_name) = @_; |
ca01a97b |
132 | my $code = 'sub {' |
133 | . 'confess "Cannot assign a value to a read-only accessor" if @_ > 1;' |
134 | . ($self->is_lazy ? |
135 | '$_[0]->{$attr_name} = ($self->has_default ? $self->default($_[0]) : undef)' |
136 | . 'unless exists $_[0]->{$attr_name};' |
137 | : '') |
138 | . '$_[0]->{$attr_name};' |
139 | . '}'; |
140 | my $sub = eval $code; |
141 | confess "Could not create reader for '$attr_name' because $@ \n code: $code" if $@; |
142 | return $sub; |
d7f17ebb |
143 | } |
144 | |
c0e30cf5 |
145 | 1; |
146 | |
147 | __END__ |
148 | |
149 | =pod |
150 | |
151 | =head1 NAME |
152 | |
6ba6d68c |
153 | Moose::Meta::Attribute - The Moose attribute metaclass |
c0e30cf5 |
154 | |
155 | =head1 DESCRIPTION |
156 | |
e522431d |
157 | This is a subclass of L<Class::MOP::Attribute> with Moose specific |
6ba6d68c |
158 | extensions. |
159 | |
160 | For the most part, the only time you will ever encounter an |
161 | instance of this class is if you are doing some serious deep |
162 | introspection. To really understand this class, you need to refer |
163 | to the L<Class::MOP::Attribute> documentation. |
e522431d |
164 | |
c0e30cf5 |
165 | =head1 METHODS |
166 | |
6ba6d68c |
167 | =head2 Overridden methods |
168 | |
169 | These methods override methods in L<Class::MOP::Attribute> and add |
170 | Moose specific features. You can safely assume though that they |
171 | will behave just as L<Class::MOP::Attribute> does. |
172 | |
c0e30cf5 |
173 | =over 4 |
174 | |
175 | =item B<new> |
176 | |
a15dff8d |
177 | =item B<generate_accessor_method> |
178 | |
179 | =item B<generate_writer_method> |
180 | |
d7f17ebb |
181 | =item B<generate_reader_method> |
182 | |
a15dff8d |
183 | =back |
184 | |
6ba6d68c |
185 | =head2 Additional Moose features |
186 | |
187 | Moose attributes support type-contstraint checking, weak reference |
188 | creation and type coercion. |
189 | |
a15dff8d |
190 | =over 4 |
191 | |
192 | =item B<has_type_constraint> |
193 | |
6ba6d68c |
194 | Returns true if this meta-attribute has a type constraint. |
195 | |
a15dff8d |
196 | =item B<type_constraint> |
197 | |
6ba6d68c |
198 | A read-only accessor for this meta-attribute's type constraint. For |
199 | more information on what you can do with this, see the documentation |
200 | for L<Moose::Meta::TypeConstraint>. |
a15dff8d |
201 | |
6ba6d68c |
202 | =item B<is_weak_ref> |
a15dff8d |
203 | |
6ba6d68c |
204 | Returns true of this meta-attribute produces a weak reference. |
4b598ea3 |
205 | |
ca01a97b |
206 | =item B<is_required> |
207 | |
208 | Returns true of this meta-attribute is required to have a value. |
209 | |
210 | =item B<is_lazy> |
211 | |
212 | Returns true of this meta-attribute should be initialized lazily. |
213 | |
214 | NOTE: lazy attributes, B<must> have a C<default> field set. |
215 | |
34a66aa3 |
216 | =item B<should_coerce> |
4b598ea3 |
217 | |
6ba6d68c |
218 | Returns true of this meta-attribute should perform type coercion. |
219 | |
c0e30cf5 |
220 | =back |
221 | |
222 | =head1 BUGS |
223 | |
224 | All complex software has bugs lurking in it, and this module is no |
225 | exception. If you find a bug please either email me, or add the bug |
226 | to cpan-RT. |
227 | |
c0e30cf5 |
228 | =head1 AUTHOR |
229 | |
230 | Stevan Little E<lt>stevan@iinteractive.comE<gt> |
231 | |
232 | =head1 COPYRIGHT AND LICENSE |
233 | |
234 | Copyright 2006 by Infinity Interactive, Inc. |
235 | |
236 | L<http://www.iinteractive.com> |
237 | |
238 | This library is free software; you can redistribute it and/or modify |
239 | it under the same terms as Perl itself. |
240 | |
241 | =cut |