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, $meta_instance, $instance, $params) = @_;
162 my $init_arg = $self->init_arg();
163 # try to fetch the init arg from the %params ...
166 if (exists $params->{$init_arg}) {
167 $val = $params->{$init_arg};
170 # skip it if it's lazy
171 return if $self->is_lazy;
172 # and die if it's required and doesn't have a default value
173 confess "Attribute (" . $self->name . ") is required"
174 if $self->is_required && !$self->has_default;
177 # if nothing was in the %params, we can use the
178 # attribute's default value (if it has one)
179 if (!defined $val && $self->has_default) {
180 $val = $self->default($instance);
183 if ($self->has_type_constraint) {
184 my $type_constraint = $self->type_constraint;
185 if ($self->should_coerce && $type_constraint->has_coercion) {
186 $val = $type_constraint->coercion->coerce($val);
188 (defined($type_constraint->check($val)))
189 || confess "Attribute (" .
191 ") does not pass the type contraint (" .
192 $type_constraint->name .
197 $meta_instance->set_slot_value( $instance, $self->name, $val );
198 $meta_instance->weaken_slot_value( $instance, $self->name ) if ( ref $val && $self->is_weak_ref );
201 sub _inline_check_constraint {
202 my ( $self, $value ) = @_;
203 return '' unless $self->has_type_constraint;
205 # FIXME - remove 'unless defined($value) - constraint Undef
206 return sprintf <<'EOF', $value, $value, $value, $value
207 defined($attr->type_constraint->check(%s))
208 || confess "Attribute (" . $attr->name . ") does not pass the type contraint ("
209 . $attr->type_constraint->name . ") with " . (defined(%s) ? "'%s'" : "undef")
215 my ( $self, $instance, $value ) = @_;
217 my $mi = $self->associated_class->get_meta_instance;
218 my $slot_name = sprintf "'%s'", $self->name;
220 return ( $self->is_weak_ref
221 ? $mi->inline_set_slot_value_weak( $instance, $slot_name, $value )
222 : $mi->inline_set_slot_value( $instance, $slot_name, $value ) ) . ";";
225 sub _inline_trigger {
226 my ( $self, $instance, $value ) = @_;
227 return '' unless $self->has_trigger;
228 return sprintf('$attr->trigger->(%s, %s, $attr);', $instance, $value);
232 my ( $self, $instance ) = @_;
234 my $mi = $self->associated_class->get_meta_instance;
235 my $slot_name = sprintf "'%s'", $self->name;
237 return $mi->inline_get_slot_value( $instance, $slot_name );
240 sub generate_accessor_method {
241 my ($attr, $attr_name) = @_;
242 my $value_name = $attr->should_coerce ? '$val' : '$_[1]';
243 my $mi = $attr->associated_class->get_meta_instance;
244 my $slot_name = sprintf "'%s'", $attr->name;
247 . 'if (scalar(@_) == 2) {'
248 . ($attr->is_required ?
249 'defined($_[1]) || confess "Attribute ($attr_name) is required, so cannot be set to undef";'
251 . ($attr->should_coerce ?
252 'my $val = $attr->type_constraint->coercion->coerce($_[1]);'
254 . $attr->_inline_check_constraint( $value_name )
255 . $attr->_inline_store( $inv, $value_name )
256 . $attr->_inline_trigger( $inv, $value_name )
259 '$_[0]->{$attr_name} = ($attr->has_default ? $attr->default($_[0]) : undef)'
260 . 'unless exists $_[0]->{$attr_name};'
262 . 'return ' . $attr->_inline_get( $inv )
264 my $sub = eval $code;
265 warn "Could not create accessor for '$attr_name' because $@ \n code: $code" if $@;
266 confess "Could not create accessor for '$attr_name' because $@ \n code: $code" if $@;
270 sub generate_writer_method {
271 my ($attr, $attr_name) = @_;
272 my $value_name = $attr->should_coerce ? '$val' : '$_[1]';
275 . ($attr->is_required ?
276 'defined($_[1]) || confess "Attribute ($attr_name) is required, so cannot be set to undef";'
278 . ($attr->should_coerce ?
279 'my $val = $attr->type_constraint->coercion->coerce($_[1]);'
281 . $attr->_inline_check_constraint( $value_name )
282 . $attr->_inline_store( $inv, $value_name )
283 . $attr->_inline_trigger( $inv, $value_name )
285 my $sub = eval $code;
286 confess "Could not create writer for '$attr_name' because $@ \n code: $code" if $@;
290 sub generate_reader_method {
291 my ($self, $attr_name) = @_;
293 . 'confess "Cannot assign a value to a read-only accessor" if @_ > 1;'
295 '$_[0]->{$attr_name} = ($self->has_default ? $self->default($_[0]) : undef)'
296 . 'unless exists $_[0]->{$attr_name};'
298 . '$_[0]->{$attr_name};'
300 my $sub = eval $code;
301 confess "Could not create reader for '$attr_name' because $@ \n code: $code" if $@;
313 Moose::Meta::Attribute - The Moose attribute metaclass
317 This is a subclass of L<Class::MOP::Attribute> with Moose specific
320 For the most part, the only time you will ever encounter an
321 instance of this class is if you are doing some serious deep
322 introspection. To really understand this class, you need to refer
323 to the L<Class::MOP::Attribute> documentation.
327 =head2 Overridden methods
329 These methods override methods in L<Class::MOP::Attribute> and add
330 Moose specific features. You can safely assume though that they
331 will behave just as L<Class::MOP::Attribute> does.
337 =item B<clone_and_inherit_options>
339 =item B<initialize_instance_slot>
341 =item B<generate_accessor_method>
343 =item B<generate_writer_method>
345 =item B<generate_reader_method>
349 =head2 Additional Moose features
351 Moose attributes support type-contstraint checking, weak reference
352 creation and type coercion.
356 =item B<has_type_constraint>
358 Returns true if this meta-attribute has a type constraint.
360 =item B<type_constraint>
362 A read-only accessor for this meta-attribute's type constraint. For
363 more information on what you can do with this, see the documentation
364 for L<Moose::Meta::TypeConstraint>.
368 Returns true if this meta-attribute produces a weak reference.
372 Returns true if this meta-attribute is required to have a value.
376 Returns true if this meta-attribute should be initialized lazily.
378 NOTE: lazy attributes, B<must> have a C<default> field set.
380 =item B<should_coerce>
382 Returns true if this meta-attribute should perform type coercion.
386 Returns true if this meta-attribute has a trigger set.
390 This is a CODE reference which will be executed every time the
391 value of an attribute is assigned. The CODE ref will get two values,
392 the invocant and the new value. This can be used to handle I<basic>
393 bi-directional relations.
399 All complex software has bugs lurking in it, and this module is no
400 exception. If you find a bug please either email me, or add the bug
405 Stevan Little E<lt>stevan@iinteractive.comE<gt>
407 =head1 COPYRIGHT AND LICENSE
409 Copyright 2006 by Infinity Interactive, Inc.
411 L<http://www.iinteractive.com>
413 This library is free software; you can redistribute it and/or modify
414 it under the same terms as Perl itself.