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 {
292 my $attr_name = $self->name;
294 . 'confess "Cannot assign a value to a read-only accessor" if @_ > 1;'
296 '$_[0]->{$attr_name} = ($self->has_default ? $self->default($_[0]) : undef)'
297 . 'unless exists $_[0]->{$attr_name};'
299 . 'return $_[0]->{$attr_name};'
301 my $sub = eval $code;
302 confess "Could not create reader for '$attr_name' because $@ \n code: $code" if $@;
314 Moose::Meta::Attribute - The Moose attribute metaclass
318 This is a subclass of L<Class::MOP::Attribute> with Moose specific
321 For the most part, the only time you will ever encounter an
322 instance of this class is if you are doing some serious deep
323 introspection. To really understand this class, you need to refer
324 to the L<Class::MOP::Attribute> documentation.
328 =head2 Overridden methods
330 These methods override methods in L<Class::MOP::Attribute> and add
331 Moose specific features. You can safely assume though that they
332 will behave just as L<Class::MOP::Attribute> does.
338 =item B<clone_and_inherit_options>
340 =item B<initialize_instance_slot>
342 =item B<generate_accessor_method>
344 =item B<generate_writer_method>
346 =item B<generate_reader_method>
350 =head2 Additional Moose features
352 Moose attributes support type-contstraint checking, weak reference
353 creation and type coercion.
357 =item B<has_type_constraint>
359 Returns true if this meta-attribute has a type constraint.
361 =item B<type_constraint>
363 A read-only accessor for this meta-attribute's type constraint. For
364 more information on what you can do with this, see the documentation
365 for L<Moose::Meta::TypeConstraint>.
369 Returns true if this meta-attribute produces a weak reference.
373 Returns true if this meta-attribute is required to have a value.
377 Returns true if this meta-attribute should be initialized lazily.
379 NOTE: lazy attributes, B<must> have a C<default> field set.
381 =item B<should_coerce>
383 Returns true if this meta-attribute should perform type coercion.
387 Returns true if this meta-attribute has a trigger set.
391 This is a CODE reference which will be executed every time the
392 value of an attribute is assigned. The CODE ref will get two values,
393 the invocant and the new value. This can be used to handle I<basic>
394 bi-directional relations.
400 All complex software has bugs lurking in it, and this module is no
401 exception. If you find a bug please either email me, or add the bug
406 Stevan Little E<lt>stevan@iinteractive.comE<gt>
408 =head1 COPYRIGHT AND LICENSE
410 Copyright 2006 by Infinity Interactive, Inc.
412 L<http://www.iinteractive.com>
414 This library is free software; you can redistribute it and/or modify
415 it under the same terms as Perl itself.