2 package Moose::Meta::Attribute;
7 use Scalar::Util 'blessed', 'weaken', 'reftype';
10 our $VERSION = '0.05';
12 use Moose::Util::TypeConstraints ();
14 use base 'Class::MOP::Attribute';
16 __PACKAGE__->meta->add_attribute('required' => (reader => 'is_required' ));
17 __PACKAGE__->meta->add_attribute('lazy' => (reader => 'is_lazy' ));
18 __PACKAGE__->meta->add_attribute('coerce' => (reader => 'should_coerce'));
19 __PACKAGE__->meta->add_attribute('weak_ref' => (reader => 'is_weak_ref' ));
20 __PACKAGE__->meta->add_attribute('type_constraint' => (
21 reader => 'type_constraint',
22 predicate => 'has_type_constraint',
24 __PACKAGE__->meta->add_attribute('trigger' => (
26 predicate => 'has_trigger',
30 my ($class, $name, %options) = @_;
31 $class->_process_options($name, \%options);
32 $class->SUPER::new($name, %options);
35 sub clone_and_inherit_options {
36 my ($self, %options) = @_;
37 # you can change default, required and coerce
39 foreach my $legal_option (qw(default coerce required)) {
40 if (exists $options{$legal_option}) {
41 $actual_options{$legal_option} = $options{$legal_option};
42 delete $options{$legal_option};
45 # isa can be changed, but only if the
46 # new type is a subtype
49 if (blessed($options{isa}) && $options{isa}->isa('Moose::Meta::TypeConstraint')) {
50 $type_constraint = $options{isa};
53 $type_constraint = Moose::Util::TypeConstraints::find_type_constraint($options{isa});
54 (defined $type_constraint)
55 || confess "Could not find the type constraint '" . $options{isa} . "'";
57 ($type_constraint->is_subtype_of($self->type_constraint->name))
58 || confess "New type constraint setting must be a subtype of inherited one"
59 if $self->has_type_constraint;
60 $actual_options{type_constraint} = $type_constraint;
63 (scalar keys %options == 0)
64 || confess "Illegal inherited options => (" . (join ', ' => keys %options) . ")";
65 $self->clone(%actual_options);
68 sub _process_options {
69 my ($class, $name, $options) = @_;
70 if (exists $options->{is}) {
71 if ($options->{is} eq 'ro') {
72 $options->{reader} = $name;
73 (!exists $options->{trigger})
74 || confess "Cannot have a trigger on a read-only attribute";
76 elsif ($options->{is} eq 'rw') {
77 $options->{accessor} = $name;
78 ((reftype($options->{trigger}) || '') eq 'CODE')
79 || confess "A trigger must be a CODE reference"
80 if exists $options->{trigger};
84 if (exists $options->{isa}) {
86 if (exists $options->{does}) {
87 if (eval { $options->{isa}->can('does') }) {
88 ($options->{isa}->does($options->{does}))
89 || confess "Cannot have an isa option and a does option if the isa does not do the does";
92 confess "Cannot have an isa option which cannot ->does()";
96 # allow for anon-subtypes here ...
97 if (blessed($options->{isa}) && $options->{isa}->isa('Moose::Meta::TypeConstraint')) {
98 $options->{type_constraint} = $options->{isa};
102 if ($options->{isa} =~ /\|/) {
103 my @type_constraints = split /\s*\|\s*/ => $options->{isa};
104 $options->{type_constraint} = Moose::Util::TypeConstraints::create_type_constraint_union(
109 # otherwise assume it is a constraint
110 my $constraint = Moose::Util::TypeConstraints::find_type_constraint($options->{isa});
111 # if the constraing it not found ....
112 unless (defined $constraint) {
113 # assume it is a foreign class, and make
114 # an anon constraint for it
115 $constraint = Moose::Util::TypeConstraints::subtype(
117 Moose::Util::TypeConstraints::where { $_->isa($options->{isa}) }
120 $options->{type_constraint} = $constraint;
124 elsif (exists $options->{does}) {
125 # allow for anon-subtypes here ...
126 if (blessed($options->{does}) && $options->{does}->isa('Moose::Meta::TypeConstraint')) {
127 $options->{type_constraint} = $options->{isa};
130 # otherwise assume it is a constraint
131 my $constraint = Moose::Util::TypeConstraints::find_type_constraint($options->{does});
132 # if the constraing it not found ....
133 unless (defined $constraint) {
134 # assume it is a foreign class, and make
135 # an anon constraint for it
136 $constraint = Moose::Util::TypeConstraints::subtype(
138 Moose::Util::TypeConstraints::where { $_->does($options->{does}) }
141 $options->{type_constraint} = $constraint;
145 if (exists $options->{coerce} && $options->{coerce}) {
146 (exists $options->{type_constraint})
147 || confess "You cannot have coercion without specifying a type constraint";
148 (!$options->{type_constraint}->isa('Moose::Meta::TypeConstraint::Union'))
149 || confess "You cannot have coercion with a type constraint union";
150 confess "You cannot have a weak reference to a coerced value"
151 if $options->{weak_ref};
154 if (exists $options->{lazy} && $options->{lazy}) {
155 (exists $options->{default})
156 || confess "You cannot have lazy attribute without specifying a default value for it";
160 sub initialize_instance_slot {
161 my ($self, $class, $instance, $params) = @_;
162 my $init_arg = $self->init_arg();
163 # try to fetch the init arg from the %params ...
165 if (exists $params->{$init_arg}) {
166 $val = $params->{$init_arg};
169 # skip it if it's lazy
170 return if $self->is_lazy;
171 # and die if it's required and doesn't have a default value
172 confess "Attribute (" . $self->name . ") is required"
173 if $self->is_required && !$self->has_default;
175 # if nothing was in the %params, we can use the
176 # attribute's default value (if it has one)
177 if (!defined $val && $self->has_default) {
178 $val = $self->default($instance);
181 if ($self->has_type_constraint) {
182 my $type_constraint = $self->type_constraint;
183 if ($self->should_coerce && $type_constraint->has_coercion) {
184 $val = $type_constraint->coercion->coerce($val);
186 (defined($type_constraint->check($val)))
187 || confess "Attribute (" .
189 ") does not pass the type contraint (" .
190 $type_constraint->name .
194 $instance->{$self->name} = $val;
195 if (defined $val && $self->is_weak_ref) {
196 weaken($instance->{$self->name});
200 sub generate_accessor_method {
201 my ($self, $attr_name) = @_;
202 my $value_name = $self->should_coerce ? '$val' : '$_[1]';
204 . 'if (scalar(@_) == 2) {'
205 . ($self->is_required ?
206 'defined($_[1]) || confess "Attribute ($attr_name) is required, so cannot be set to undef";'
208 . ($self->should_coerce ?
209 'my $val = $self->type_constraint->coercion->coerce($_[1]);'
211 . ($self->has_type_constraint ?
212 ('(defined $self->type_constraint->check(' . $value_name . '))'
213 . '|| confess "Attribute ($attr_name) does not pass the type contraint (" . $self->type_constraint->name . ") with \'' . $value_name . '\'"'
214 . 'if defined ' . $value_name . ';')
216 . '$_[0]->{$attr_name} = ' . $value_name . ';'
217 . ($self->is_weak_ref ?
218 'weaken($_[0]->{$attr_name});'
220 . ($self->has_trigger ?
221 '$self->trigger->($_[0], ' . $value_name . ', $self);'
225 '$_[0]->{$attr_name} = ($self->has_default ? $self->default($_[0]) : undef)'
226 . 'unless exists $_[0]->{$attr_name};'
228 . ' $_[0]->{$attr_name};'
230 my $sub = eval $code;
231 confess "Could not create writer for '$attr_name' because $@ \n code: $code" if $@;
235 sub generate_writer_method {
236 my ($self, $attr_name) = @_;
237 my $value_name = $self->should_coerce ? '$val' : '$_[1]';
239 . ($self->is_required ?
240 'defined($_[1]) || confess "Attribute ($attr_name) is required, so cannot be set to undef";'
242 . ($self->should_coerce ?
243 'my $val = $self->type_constraint->coercion->coerce($_[1]);'
245 . ($self->has_type_constraint ?
246 ('(defined $self->type_constraint->check(' . $value_name . '))'
247 . '|| confess "Attribute ($attr_name) does not pass the type contraint (" . $self->type_constraint->name . ") with \'' . $value_name . '\'"'
248 . 'if defined ' . $value_name . ';')
250 . '$_[0]->{$attr_name} = ' . $value_name . ';'
251 . ($self->is_weak_ref ?
252 'weaken($_[0]->{$attr_name});'
254 . ($self->has_trigger ?
255 '$self->trigger->($_[0], ' . $value_name . ', $self);'
258 my $sub = eval $code;
259 confess "Could not create writer for '$attr_name' because $@ \n code: $code" if $@;
263 sub generate_reader_method {
264 my ($self, $attr_name) = @_;
266 . 'confess "Cannot assign a value to a read-only accessor" if @_ > 1;'
268 '$_[0]->{$attr_name} = ($self->has_default ? $self->default($_[0]) : undef)'
269 . 'unless exists $_[0]->{$attr_name};'
271 . '$_[0]->{$attr_name};'
273 my $sub = eval $code;
274 confess "Could not create reader for '$attr_name' because $@ \n code: $code" if $@;
286 Moose::Meta::Attribute - The Moose attribute metaclass
290 This is a subclass of L<Class::MOP::Attribute> with Moose specific
293 For the most part, the only time you will ever encounter an
294 instance of this class is if you are doing some serious deep
295 introspection. To really understand this class, you need to refer
296 to the L<Class::MOP::Attribute> documentation.
300 =head2 Overridden methods
302 These methods override methods in L<Class::MOP::Attribute> and add
303 Moose specific features. You can safely assume though that they
304 will behave just as L<Class::MOP::Attribute> does.
310 =item B<clone_and_inherit_options>
312 =item B<initialize_instance_slot>
314 =item B<generate_accessor_method>
316 =item B<generate_writer_method>
318 =item B<generate_reader_method>
322 =head2 Additional Moose features
324 Moose attributes support type-contstraint checking, weak reference
325 creation and type coercion.
329 =item B<has_type_constraint>
331 Returns true if this meta-attribute has a type constraint.
333 =item B<type_constraint>
335 A read-only accessor for this meta-attribute's type constraint. For
336 more information on what you can do with this, see the documentation
337 for L<Moose::Meta::TypeConstraint>.
341 Returns true if this meta-attribute produces a weak reference.
345 Returns true if this meta-attribute is required to have a value.
349 Returns true if this meta-attribute should be initialized lazily.
351 NOTE: lazy attributes, B<must> have a C<default> field set.
353 =item B<should_coerce>
355 Returns true if this meta-attribute should perform type coercion.
359 Returns true if this meta-attribute has a trigger set.
363 This is a CODE reference which will be executed every time the
364 value of an attribute is assigned. The CODE ref will get two values,
365 the invocant and the new value. This can be used to handle I<basic>
366 bi-directional relations.
372 All complex software has bugs lurking in it, and this module is no
373 exception. If you find a bug please either email me, or add the bug
378 Stevan Little E<lt>stevan@iinteractive.comE<gt>
380 =head1 COPYRIGHT AND LICENSE
382 Copyright 2006 by Infinity Interactive, Inc.
384 L<http://www.iinteractive.com>
386 This library is free software; you can redistribute it and/or modify
387 it under the same terms as Perl itself.