Revision history for Perl extension Moose
+0.75
+ * Moose::Meta::Method::Accessor
+ - If an attribute had a lazy default, and that value did not
+ pass the attribute's type constraint, it did not get the
+ message from the type constraint, instead using a generic
+ message. Test provided by perigrin.
+
0.73 Fri, March 29, 2009
* No changes from 0.72_01.
=item L<Moose::Cookbook::Meta::Recipe5> - The "table" attribute implemented as a metaclass trait
-This example takes the class metaclass we saw in the previous recipe
+This recipe takes the class metaclass we saw in the previous recipe
and reimplements it as a metaclass trait.
-=item L<Moose::Cookbook::Meta::Recipe6> - Hooking into the immutabilization system (TODO)
+=item L<Moose::Cookbook::Meta::Recipe6> - A method metaclass for marking methods public or private
+
+This recipe shows a custom method metaclass that implements making a
+method private.
+
+=item L<Moose::Cookbook::Meta::Recipe7> - Using a blessed array reference as an object instance
+
+This recipe shows an example of how you create your own meta-instance
+class. The meta-instance determines the internal structure of object
+instances and provide access to attribute slots.
+
+=item L<Moose::Cookbook::Meta::Recipe8> - Hooking into immutabilization (TODO)
Moose has a feature known as "immutabilization". By calling C<<
__PACKAGE__->meta()->make_immutable() >> after defining your class
This recipe shows you how to write extensions which immutabilize
properly.
-=item L<Moose::Cookbook::Meta::Recipe7> - Using a blessed array reference as an object instance
-
-This recipe shows an example of how you create your own meta-instance
-class. The meta-instance determines the internal structure of object
-instances and provide access to attribute slots.
-
=back
=head2 Extending Moose
$self->{policy} = $options{policy};
That is necessary because Moose metaclasses do not use the meta API to
-create objects. Most Moose classe have a custom "inlined" constructor
+create objects. Most Moose classes have a custom "inlined" constructor
for speed.
In this particular case, our parent class's constructor is the C<wrap>
return unless $value_is_set;
- if ($self->has_type_constraint) {
- my $type_constraint = $self->type_constraint;
- if ($self->should_coerce && $type_constraint->has_coercion) {
- $val = $type_constraint->coerce($val);
- }
- $self->verify_against_type_constraint($val, instance => $instance);
- }
+ $val = $self->_coerce_and_verify( $val, $instance );
$self->set_initial_value($instance, $val);
$meta_instance->weaken_slot_value($instance, $self->name)
}
my $callback = sub {
- my $val = shift;
- if ($type_constraint) {
- $val = $type_constraint->coerce($val)
- if $can_coerce;
- $self->verify_against_type_constraint($val, object => $instance);
- }
+ my $val = $self->_coerce_and_verify( shift, $instance );;
+
$meta_instance->set_slot_value($instance, $slot_name, $val);
};
$self->throw_error("Attribute ($attr_name) is required", object => $instance);
}
- if ($self->has_type_constraint) {
-
- my $type_constraint = $self->type_constraint;
-
- if ($self->should_coerce) {
- $value = $type_constraint->coerce($value);
- }
- $type_constraint->_compiled_type_constraint->($value)
- || $self->throw_error("Attribute ("
- . $self->name
- . ") does not pass the type constraint because "
- . $type_constraint->get_message($value), object => $instance, data => $value);
- }
+ $value = $self->_coerce_and_verify( $value, $instance );
my $meta_instance = Class::MOP::Class->initialize(blessed($instance))
->get_meta_instance;
} elsif ( $self->has_builder ) {
$value = $self->_call_builder($instance);
}
- if ($self->has_type_constraint) {
- my $type_constraint = $self->type_constraint;
- $value = $type_constraint->coerce($value)
- if ($self->should_coerce);
- $self->verify_against_type_constraint($value);
- }
+
+ $value = $self->_coerce_and_verify( $value, $instance );
+
$self->set_initial_value($instance, $value);
}
}
);
}
+sub _coerce_and_verify {
+ my $self = shift;
+ my $val = shift;
+ my $instance = shift;
+
+ return $val unless $self->has_type_constraint;
+
+ my $type_constraint = $self->type_constraint;
+ if ($self->should_coerce && $type_constraint->has_coercion) {
+ $val = $type_constraint->coerce($val);
+ }
+
+ $self->verify_against_type_constraint($val, instance => $instance);
+
+ return $val;
+}
+
sub verify_against_type_constraint {
my $self = shift;
my $val = shift;
. 'if (scalar(@_) >= 2) {' . "\n"
. $self->_inline_copy_value . "\n"
. $self->_inline_check_required . "\n"
- . $self->_inline_check_coercion . "\n"
+ . $self->_inline_check_coercion($value_name) . "\n"
. $self->_inline_check_constraint($value_name) . "\n"
. $self->_inline_store($inv, $value_name) . "\n"
. $self->_inline_trigger($inv, $value_name) . "\n"
. $self->_inline_pre_body(@_)
. $self->_inline_copy_value
. $self->_inline_check_required
- . $self->_inline_check_coercion
+ . $self->_inline_check_coercion($value_name)
. $self->_inline_check_constraint($value_name)
. $self->_inline_store($inv, $value_name)
. $self->_inline_post_body(@_)
}
sub _inline_check_coercion {
- my $attr = (shift)->associated_attribute;
+ my ($self, $value) = @_;
+
+ my $attr = $self->associated_attribute;
return '' unless $attr->should_coerce;
- return '$val = $attr->type_constraint->coerce($_[1]);'
+ return "$value = \$attr->type_constraint->coerce($value);";
}
sub _inline_check_required {
' ' . $self->_inline_throw_error(q{sprintf "%s does not support builder method '%s' for attribute '%s'", ref(} . $instance . ') || '.$instance.', $attr->builder, $attr->name') .
';'. "\n }";
}
- $code .= ' $default = $type_constraint_obj->coerce($default);'."\n" if $attr->should_coerce;
- $code .= ' ($type_constraint->($default))' .
- ' || ' . $self->_inline_throw_error('"Attribute (" . $attr_name . ") does not pass the type constraint ("' .
- ' . $type_constraint_name . ") with " . (defined($default) ? overload::StrVal($default) : "undef")' ) . ';'
- . "\n";
+ $code .= $self->_inline_check_coercion('$default') . "\n";
+ $code .= $self->_inline_check_constraint('$default') . "\n";
$code .= ' ' . $self->_inline_init_slot($attr, $instance, $slot_access, '$default') . "\n";
}
else {
use strict;
use warnings;
-use Test::More tests => 10;
+use Test::More tests => 9;
use Test::Exception;
{
package Animal;
use Moose;
- BEGIN {
- ::use_ok("Moose::Util::TypeConstraints");
- }
+ use Moose::Util::TypeConstraints;
- subtype 'Natural'
- => as 'Int'
- => where { $_ > 0 }
- => message { "This number ($_) is not a positive integer!" };
+ subtype 'Natural' => as 'Int' => where { $_ > 0 } =>
+ message {"This number ($_) is not a positive integer!"};
- subtype 'NaturalLessThanTen'
- => as 'Natural'
- => where { $_ < 10 }
- => message { "This number ($_) is not less than ten!" };
+ subtype 'NaturalLessThanTen' => as 'Natural' => where { $_ < 10 } =>
+ message {"This number ($_) is not less than ten!"};
has leg_count => (
- is => 'rw',
- isa => 'NaturalLessThanTen',
- lazy => 1,
+ is => 'rw',
+ isa => 'NaturalLessThanTen',
+ lazy => 1,
default => 0,
-
);
-
}
-lives_ok { my $goat = Animal->new(leg_count => 4) } '... no errors thrown, value is good';
-lives_ok { my $spider = Animal->new(leg_count => 8) } '... no errors thrown, value is good';
+lives_ok { my $goat = Animal->new( leg_count => 4 ) }
+'... no errors thrown, value is good';
+lives_ok { my $spider = Animal->new( leg_count => 8 ) }
+'... no errors thrown, value is good';
-throws_ok { my $fern = Animal->new(leg_count => 0) }
- qr/This number \(0\) is not less than ten!/,
- "gave custom supertype error message on new";
+throws_ok { my $fern = Animal->new( leg_count => 0 ) }
+qr/This number \(0\) is not less than ten!/,
+ 'gave custom supertype error message on new';
-throws_ok { my $centipede = Animal->new(leg_count => 30) }
- qr/This number \(30\) is not less than ten!/,
- "gave custom subtype error message on new";
+throws_ok { my $centipede = Animal->new( leg_count => 30 ) }
+qr/This number \(30\) is not less than ten!/,
+ 'gave custom subtype error message on new';
my $chimera;
-lives_ok { $chimera = Animal->new(leg_count => 4) } '... no errors thrown, value is good';
+lives_ok { $chimera = Animal->new( leg_count => 4 ) }
+'... no errors thrown, value is good';
-# first we remove the lion's legs..
throws_ok { $chimera->leg_count(0) }
- qr/This number \(0\) is not less than ten!/,
- "gave custom supertype error message on set_value";
+qr/This number \(0\) is not less than ten!/,
+ 'gave custom supertype error message on set to 0';
-# mix in a few octopodes
throws_ok { $chimera->leg_count(16) }
- qr/This number \(16\) is not less than ten!/,
- "gave custom subtype error message on set_value";
+qr/This number \(16\) is not less than ten!/,
+ 'gave custom subtype error message on set to 16';
+
+my $gimp = eval { Animal->new() };
+is( $@, '', '... no errors thrown, value is good' );
-# try the lazy legs
-my $gimp;
-lives_ok { my $gimp = Animal->new() } '... no errors thrown, value is good';
throws_ok { $gimp->leg_count }
- qr/This number \(0\) is not less than ten!/,
- "gave custom supertype error message on set_value";
-
+qr/This number \(0\) is not less than ten!/,
+ 'gave custom supertype error message on lazy set to 0';
+
projects / gitmo/Moose.git / commitdiff