From: Stevan Little Date: Mon, 28 Jan 2008 02:45:26 +0000 (+0000) Subject: type constraint messages work now (kinda) and other misc cleanup so that tests run... X-Git-Tag: 0_37~15 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=688fcdda5c37b86784f8a923b636bdbbf47181d5;p=gitmo%2FMoose.git type constraint messages work now (kinda) and other misc cleanup so that tests run (see Changelog) --- diff --git a/Changes b/Changes index 1cb63ce..07d6d75 100644 --- a/Changes +++ b/Changes @@ -1,5 +1,26 @@ Revision history for Perl extension Moose +0.37 + * Moose + - fixed some details in Moose::init_meta + and its superclass handling (thanks thepler) + - added tests for this (thanks thepler) + + * Moose::Meta::Class + Moose::Meta::Method::Constructor + Moose::Meta::Attribute + - making (init_arg => undef) work here too + (thanks to nothingmuch) + + * Moose::Util::TypeConstraints + Moose::Util::TypeConstraints::OptimizedConstraints + Moose::Meta::Attribute + Moose::Meta::Method::Constructor + Moose::Meta::Method::Accessor + - making type errors use the + assigned message (thanks to Sartak) + - added tests for this + 0.36 Sat. Jan. 26, 2008 * Moose::Role Moose::Meta::Attribute diff --git a/MANIFEST b/MANIFEST index 2ff063a..f18745b 100644 --- a/MANIFEST +++ b/MANIFEST @@ -147,6 +147,8 @@ t/050_metaclasses/001_custom_attr_meta_with_roles.t t/050_metaclasses/002_custom_attr_meta_as_role.t t/050_metaclasses/003_moose_w_metaclass.t t/050_metaclasses/004_moose_for_meta.t +t/050_metaclasses/010_extending_and_embedding.t +t/050_metaclasses/011_init_meta.t t/060_compat/001_module_refresh_compat.t t/060_compat/002_moose_respects_base.t t/060_compat/003_foreign_inheritence.t diff --git a/Makefile.PL b/Makefile.PL index 2569da9..5a94024 100644 --- a/Makefile.PL +++ b/Makefile.PL @@ -12,7 +12,7 @@ my $win32 = !! ( $^O eq 'Win32' or $^O eq 'cygwin' ); # prereqs requires 'Scalar::Util' => $win32 ? '1.17' : '1.18'; requires 'Carp'; -requires 'Class::MOP' => '0.51'; +requires 'Class::MOP' => '0.53'; requires 'Sub::Name' => '0.02'; requires 'Sub::Exporter' => '0.972'; diff --git a/README b/README index 2a64033..701119f 100644 --- a/README +++ b/README @@ -1,4 +1,4 @@ -Moose version 0.36 +Moose version 0.37 =========================== See the individual module documentation for more information diff --git a/lib/Moose.pm b/lib/Moose.pm index fdfa332..ee92a9b 100644 --- a/lib/Moose.pm +++ b/lib/Moose.pm @@ -4,7 +4,7 @@ package Moose; use strict; use warnings; -our $VERSION = '0.36'; +our $VERSION = '0.37'; our $AUTHORITY = 'cpan:STEVAN'; use Scalar::Util 'blessed', 'reftype'; @@ -33,8 +33,8 @@ use Moose::Util (); sub init_meta { my ( $class, $base_class, $metaclass ) = @_; - $base_class = $class unless defined $base_class; - $metaclass = 'Moose::Meta::Class' unless defined $metaclass; + $base_class = 'Moose::Object' unless defined $base_class; + $metaclass = 'Moose::Meta::Class' unless defined $metaclass; confess "The Metaclass $metaclass must be a subclass of Moose::Meta::Class." @@ -73,6 +73,8 @@ use Moose::Util (); # make sure they inherit from Moose::Object $meta->superclasses($base_class) unless $meta->superclasses(); + + return $meta; } my %exports = ( diff --git a/lib/Moose/Meta/Attribute.pm b/lib/Moose/Meta/Attribute.pm index 0d5b2a0..111c646 100644 --- a/lib/Moose/Meta/Attribute.pm +++ b/lib/Moose/Meta/Attribute.pm @@ -248,15 +248,10 @@ sub initialize_instance_slot { $val = $type_constraint->coerce($val); } (defined($type_constraint->check($val))) - || confess "Attribute (" . - $self->name . - ") does not pass the type constraint (" . - $type_constraint->name . - ") with '" . - (defined $val - ? overload::StrVal($val) - : 'undef') . - "'"; + || confess "Attribute (" + . $self->name + . ") does not pass the type constraint because: " + . $type_constraint->get_message($val); } $meta_instance->set_slot_value($instance, $self->name, $val); @@ -282,15 +277,13 @@ sub set_value { if ($self->should_coerce) { $value = $type_constraint->coerce($value); - } + } $type_constraint->_compiled_type_constraint->($value) - || confess "Attribute ($attr_name) does not pass the type constraint (" - . $type_constraint->name - . ") with " - . (defined($value) - ? ("'" . overload::StrVal($value) . "'") - : "undef") - if defined($value); + || confess "Attribute (" + . $self->name + . ") does not pass the type constraint because " + . $type_constraint->get_message($value) + if defined($value); } my $meta_instance = Class::MOP::Class->initialize(blessed($instance)) diff --git a/lib/Moose/Meta/Method/Accessor.pm b/lib/Moose/Meta/Method/Accessor.pm index d878ed5..a5e0e80 100644 --- a/lib/Moose/Meta/Method/Accessor.pm +++ b/lib/Moose/Meta/Method/Accessor.pm @@ -6,7 +6,7 @@ use warnings; use Carp 'confess'; -our $VERSION = '0.11'; +our $VERSION = '0.12'; our $AUTHORITY = 'cpan:STEVAN'; use base 'Moose::Meta::Method', @@ -124,10 +124,10 @@ sub _inline_check_constraint { # FIXME # This sprintf is insanely annoying, we should # fix it someday - SL - return sprintf <<'EOF', $value, $attr_name, $type_constraint_name, $value, $value, $value, $value, $value, $value + return sprintf <<'EOF', $value, $attr_name, $value, $value, $type_constraint->(%s) - || confess "Attribute (%s) does not pass the type constraint (%s) with " - . (defined(%s) ? overload::StrVal(%s) : "undef") + || confess "Attribute (%s) does not pass the type constraint because: " + . $type_constraint_obj->get_message(%s) if defined(%s); EOF } diff --git a/lib/Moose/Meta/Method/Constructor.pm b/lib/Moose/Meta/Method/Constructor.pm index caefb14..73433f8 100644 --- a/lib/Moose/Meta/Method/Constructor.pm +++ b/lib/Moose/Meta/Method/Constructor.pm @@ -143,15 +143,24 @@ sub _generate_slot_initializer { if ($is_moose && $attr->has_type_constraint) { if ($attr->should_coerce && $attr->type_constraint->has_coercion) { - push @source => $self->_generate_type_coercion($attr, '$type_constraints[' . $index . ']', '$val', '$val'); + push @source => $self->_generate_type_coercion( + $attr, + '$type_constraints[' . $index . ']', + '$val', + '$val' + ); } - push @source => $self->_generate_type_constraint_check($attr, '$type_constraint_bodies[' . $index . ']', '$val'); + push @source => $self->_generate_type_constraint_check( + $attr, + '$type_constraint_bodies[' . $index . ']', + '$type_constraints[' . $index . ']', + '$val' + ); } push @source => $self->_generate_slot_assignment($attr, '$val'); push @source => "} else {"; } - my $default; if ( $attr->has_default ) { $default = $self->_generate_default_value($attr, $index); @@ -160,13 +169,17 @@ sub _generate_slot_initializer { my $builder = $attr->builder; $default = '$instance->' . $builder; } + + push @source => '{'; # wrap this to avoid my $val overrite warnings push @source => ('my $val = ' . $default . ';'); push @source => $self->_generate_type_constraint_check( $attr, ('$type_constraint_bodies[' . $index . ']'), + ('$type_constraints[' . $index . ']'), '$val' ) if ($is_moose && $attr->has_type_constraint); push @source => $self->_generate_slot_assignment($attr, $default); + push @source => '}'; # close - wrap this to avoid my $val overrite warnings push @source => "}" if defined $attr->init_arg; } @@ -176,9 +189,19 @@ sub _generate_slot_initializer { push @source => ('my $val = $params{\'' . $init_arg . '\'};'); if ($is_moose && $attr->has_type_constraint) { if ($attr->should_coerce && $attr->type_constraint->has_coercion) { - push @source => $self->_generate_type_coercion($attr, '$type_constraints[' . $index . ']', '$val', '$val'); + push @source => $self->_generate_type_coercion( + $attr, + '$type_constraints[' . $index . ']', + '$val', + '$val' + ); } - push @source => $self->_generate_type_constraint_check($attr, '$type_constraint_bodies[' . $index . ']', '$val'); + push @source => $self->_generate_type_constraint_check( + $attr, + '$type_constraint_bodies[' . $index . ']', + '$type_constraints[' . $index . ']', + '$val' + ); } push @source => $self->_generate_slot_assignment($attr, '$val'); @@ -220,12 +243,13 @@ sub _generate_type_coercion { } sub _generate_type_constraint_check { - my ($self, $attr, $type_constraint_cv, $value_name) = @_; + my ($self, $attr, $type_constraint_cv, $type_constraint_obj, $value_name) = @_; return ( $type_constraint_cv . '->(' . $value_name . ')' - . "\n\t" . '|| confess "Attribute (' . $attr->name . ') does not pass the type constraint (' - . $attr->type_constraint->name - . ') with " . (defined(' . $value_name . ') ? overload::StrVal(' . $value_name . ') : "undef");' + . "\n\t" . '|| confess "Attribute (' + . $attr->name + . ') does not pass the type constraint because: " . ' + . $type_constraint_obj . '->get_message(' . $value_name . ');' ); } diff --git a/lib/Moose/Meta/TypeConstraint.pm b/lib/Moose/Meta/TypeConstraint.pm index ad5094b..0dd9126 100644 --- a/lib/Moose/Meta/TypeConstraint.pm +++ b/lib/Moose/Meta/TypeConstraint.pm @@ -65,16 +65,22 @@ sub validate { return undef; } else { - if ($self->has_message) { - local $_ = $value; - return $self->message->($value); - } - else { - return "Validation failed for '" . $self->name . "' failed"; - } + $self->get_message($value); } } +sub get_message { + my ($self, $value) = @_; + $value = (defined $value ? overload::StrVal($value) : 'undef'); + if (my $msg = $self->message) { + local $_ = $value; + return $msg->($value); + } + else { + return "Validation failed for '" . $self->name . "' failed with value $value"; + } +} + ## type predicates ... sub is_a_type_of { @@ -249,6 +255,8 @@ the C will be used to construct a custom error message. =item B +=item B + =item B =item B diff --git a/t/010_basics/012_rebless.t b/t/010_basics/012_rebless.t index 5ce90bf..fcc5dd6 100644 --- a/t/010_basics/012_rebless.t +++ b/t/010_basics/012_rebless.t @@ -64,8 +64,12 @@ is($foo->lazy_classname, 'Parent', "lazy attribute initialized"); lives_ok { $foo->type_constrained(10.5) } "Num type constraint for now.."; # try to rebless, except it will fail due to Child's stricter type constraint -throws_ok { Child->meta->rebless_instance($foo) } qr/^Attribute \(type_constrained\) does not pass the type constraint \(Int\) with '10\.5'/; -throws_ok { Child->meta->rebless_instance($bar) } qr/^Attribute \(type_constrained\) does not pass the type constraint \(Int\) with '5\.5'/; +throws_ok { Child->meta->rebless_instance($foo) } +qr/^Attribute \(type_constrained\) does not pass the type constraint because\: Validation failed for 'Int' failed with value 10\.5/, +'... this failed cause of type check'; +throws_ok { Child->meta->rebless_instance($bar) } +qr/^Attribute \(type_constrained\) does not pass the type constraint because\: Validation failed for 'Int' failed with value 5\.5/, +'... this failed cause of type check';; $foo->type_constrained(10); $bar->type_constrained(5); @@ -79,4 +83,6 @@ is($foo->name, 'Junior', "Child->name's default came through"); is($foo->lazy_classname, 'Parent', "lazy attribute was already initialized"); is($bar->lazy_classname, 'Child', "lazy attribute just now initialized"); -throws_ok { $foo->type_constrained(10.5) } qr/^Attribute \(type_constrained\) does not pass the type constraint \(Int\) with 10\.5 /; +throws_ok { $foo->type_constrained(10.5) } +qr/^Attribute \(type_constrained\) does not pass the type constraint because\: Validation failed for 'Int' failed with value 10\.5/, +'... this failed cause of type check'; diff --git a/t/020_attributes/012_misc_attribute_tests.t b/t/020_attributes/012_misc_attribute_tests.t index d25d1c8..a64c5d9 100644 --- a/t/020_attributes/012_misc_attribute_tests.t +++ b/t/020_attributes/012_misc_attribute_tests.t @@ -120,7 +120,8 @@ BEGIN { throws_ok { $moose_obj->a_str( $moose_obj ) - } qr/Attribute \(a_str\) does not pass the type constraint \(Str\) with OverloadedStr\=HASH\(.*?\)/, '... dies without overloading the string'; + } qr/Attribute \(a_str\) does not pass the type constraint because\: Validation failed for 'Str' failed with value OverloadedStr=HASH\(0x.......\)/, + '... dies without overloading the string'; } @@ -134,7 +135,8 @@ BEGIN { throws_ok { OverloadBreaker->new; - } qr/Attribute \(a_num\) does not pass the type constraint \(Int\) with \'7\.5\'/, '... this doesnt trip overload to break anymore '; + } qr/Attribute \(a_num\) does not pass the type constraint because\: Validation failed for 'Int' failed with value 7\.5/, + '... this doesnt trip overload to break anymore '; lives_ok { OverloadBreaker->new(a_num => 5); diff --git a/t/040_type_constraints/001_util_type_constraints.t b/t/040_type_constraints/001_util_type_constraints.t index 353a344..29d628a 100644 --- a/t/040_type_constraints/001_util_type_constraints.t +++ b/t/040_type_constraints/001_util_type_constraints.t @@ -88,7 +88,7 @@ ok(!$natural->has_message, '... it does not have a message'); ok(!defined($natural->validate(5)), '... validated successfully (no error)'); is($natural->validate(-5), - "Validation failed for 'Natural' failed", + "Validation failed for 'Natural' failed with value -5", '... validated unsuccessfully (got error)'); my $string = find_type_constraint('String'); diff --git a/t/040_type_constraints/008_union_types.t b/t/040_type_constraints/008_union_types.t index 49111df..be67940 100644 --- a/t/040_type_constraints/008_union_types.t +++ b/t/040_type_constraints/008_union_types.t @@ -55,7 +55,15 @@ diag $HashOrArray->validate([]); ok(!defined($HashOrArray->validate([])), '... (ArrayRef | HashRef) can accept []'); ok(!defined($HashOrArray->validate({})), '... (ArrayRef | HashRef) can accept {}'); -is($HashOrArray->validate(\(my $var2)), 'Validation failed for \'ArrayRef\' failed and Validation failed for \'HashRef\' failed in (ArrayRef | HashRef)', '... (ArrayRef | HashRef) cannot accept scalar refs'); -is($HashOrArray->validate(sub {}), 'Validation failed for \'ArrayRef\' failed and Validation failed for \'HashRef\' failed in (ArrayRef | HashRef)', '... (ArrayRef | HashRef) cannot accept code refs'); -is($HashOrArray->validate(50), 'Validation failed for \'ArrayRef\' failed and Validation failed for \'HashRef\' failed in (ArrayRef | HashRef)', '... (ArrayRef | HashRef) cannot accept Numbers'); +like($HashOrArray->validate(\(my $var2)), +qr/Validation failed for \'ArrayRef\' failed with value SCALAR\(0x.......\) and Validation failed for \'HashRef\' failed with value SCALAR\(0x.......\) in \(ArrayRef \| HashRef\)/, +'... (ArrayRef | HashRef) cannot accept scalar refs'); + +like($HashOrArray->validate(sub {}), +qr/Validation failed for \'ArrayRef\' failed with value CODE\(0x.......\) and Validation failed for \'HashRef\' failed with value CODE\(0x.......\) in \(ArrayRef \| HashRef\)/, +'... (ArrayRef | HashRef) cannot accept code refs'); + +is($HashOrArray->validate(50), +'Validation failed for \'ArrayRef\' failed with value 50 and Validation failed for \'HashRef\' failed with value 50 in (ArrayRef | HashRef)', +'... (ArrayRef | HashRef) cannot accept Numbers'); diff --git a/t/040_type_constraints/022_custom_type_errors.t b/t/040_type_constraints/022_custom_type_errors.t index 7063e20..9167623 100644 --- a/t/040_type_constraints/022_custom_type_errors.t +++ b/t/040_type_constraints/022_custom_type_errors.t @@ -29,27 +29,27 @@ use Test::Exception; ); } -lives_ok { my $goat = Animal->new(leg_count => 4) }; -lives_ok { my $spider = Animal->new(leg_count => 8) }; +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 a positive integer!/, + 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!/, + 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) }; +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 a positive integer!/, + qr/This number \(0\) is not less than ten!/, "gave custom supertype error message on set_value"; # mix in a few octopodes throws_ok { $chimera->leg_count(16) } - qr/^This number \(16\) is not less than ten!/, + qr/This number \(16\) is not less than ten!/, "gave custom subtype error message on set_value"; diff --git a/t/050_metaclasses/010_extending_and_embedding.t b/t/050_metaclasses/010_extending_and_embedding.t new file mode 100644 index 0000000..3fce149 --- /dev/null +++ b/t/050_metaclasses/010_extending_and_embedding.t @@ -0,0 +1,60 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More tests => 8; +use Test::Exception; + +BEGIN { + use_ok('Moose'); +} + +BEGIN { + package MyFramework::Base; + use Moose; + + package MyFramework::Meta::Base; + use Moose; + + extends 'Moose::Meta::Class'; + + package MyFramework; + use Moose; + + sub import { + my $CALLER = caller(); + + strict->import; + warnings->import; + + return if $CALLER eq 'main'; + Moose::init_meta( $CALLER, 'MyFramework::Base', 'MyFramework::Meta::Base' ); + Moose->import({ into => $CALLER }); + + return 1; + } +} + +{ + package MyClass; + BEGIN { MyFramework->import } + + has 'foo' => (is => 'rw'); +} + +can_ok( 'MyClass', 'meta' ); + +isa_ok(MyClass->meta, 'MyFramework::Meta::Base'); +isa_ok(MyClass->meta, 'Moose::Meta::Class'); + +my $obj = MyClass->new(foo => 10); +isa_ok($obj, 'MyClass'); +isa_ok($obj, 'MyFramework::Base'); +isa_ok($obj, 'Moose::Object'); + +is($obj->foo, 10, '... got the right value'); + + + + diff --git a/t/050_metaclasses/011_init_meta.t b/t/050_metaclasses/011_init_meta.t new file mode 100644 index 0000000..0f83849 --- /dev/null +++ b/t/050_metaclasses/011_init_meta.t @@ -0,0 +1,20 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More tests => 5; + +BEGIN { + use_ok('Moose'); +} + +{ package Foo; } + +my $meta = Moose::init_meta('Foo'); + +ok( Foo->isa('Moose::Object'), '... Foo isa Moose::Object'); +isa_ok( $meta, 'Moose::Meta::Class' ); +isa_ok( Foo->meta, 'Moose::Meta::Class' ); + +is($meta, Foo->meta, '... our metas are the same'); diff --git a/t/300_immutable/003_immutable_meta_class.t b/t/300_immutable/003_immutable_meta_class.t index 445702b..a4214e9 100644 --- a/t/300_immutable/003_immutable_meta_class.t +++ b/t/300_immutable/003_immutable_meta_class.t @@ -17,11 +17,13 @@ BEGIN { extends 'Moose::Meta::Class'; - has 'meta_size' => - ( is => 'rw', - isa => 'Int', - ); + has 'meta_size' => ( + is => 'rw', + isa => 'Int', + ); } -lives_ok { My::Meta->meta()->make_immutable() } 'can make a meta class immutable'; +lives_ok { + My::Meta->meta()->make_immutable(debug => 0) +} '... can make a meta class immutable';