From: Stevan Little Date: Mon, 11 Feb 2008 17:00:30 +0000 (+0000) Subject: a bug fix and some tweaks X-Git-Tag: 0_37^0 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=4d12ed5b74f344f4c99e56210cf452816e71317e;p=gitmo%2FMoose.git a bug fix and some tweaks --- diff --git a/Changes b/Changes index 6c7de18..bc0623c 100644 --- a/Changes +++ b/Changes @@ -35,6 +35,12 @@ Revision history for Perl extension Moose - making sure DESTROY gets inlined properly with successive DEMOLISH calls (thanks to manito) + * Moose::Meta::Attribute + Moose::Meta::Method::Accessor + - fixed handling of undef with type constraints + (thanks to Ernesto) + - added tests for this + 0.36 Sat. Jan. 26, 2008 * Moose::Role Moose::Meta::Attribute diff --git a/lib/Moose/Meta/Attribute.pm b/lib/Moose/Meta/Attribute.pm index 1a396d6..15064d9 100644 --- a/lib/Moose/Meta/Attribute.pm +++ b/lib/Moose/Meta/Attribute.pm @@ -247,7 +247,7 @@ sub initialize_instance_slot { if ($self->should_coerce && $type_constraint->has_coercion) { $val = $type_constraint->coerce($val); } - (defined($type_constraint->check($val))) + $type_constraint->check($val) || confess "Attribute (" . $self->name . ") does not pass the type constraint because: " @@ -282,8 +282,7 @@ sub set_value { || confess "Attribute (" . $self->name . ") does not pass the type constraint because " - . $type_constraint->get_message($value) - if defined($value); + . $type_constraint->get_message($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 30efaa6..fec0e2e 100644 --- a/lib/Moose/Meta/Method/Accessor.pm +++ b/lib/Moose/Meta/Method/Accessor.pm @@ -127,8 +127,7 @@ sub _inline_check_constraint { return sprintf <<'EOF', $value, $attr_name, $value, $value, $type_constraint->(%s) || confess "Attribute (%s) does not pass the type constraint because: " - . $type_constraint_obj->get_message(%s) - if defined(%s); + . $type_constraint_obj->get_message(%s); EOF } @@ -175,8 +174,8 @@ sub _inline_check_lazy { $code .= ' $default = $type_constraint_obj->coerce($default);'."\n" if $attr->should_coerce; $code .= ' ($type_constraint->($default))' . ' || confess "Attribute (" . $attr_name . ") does not pass the type constraint ("' . - ' . $type_constraint_name . ") with " . (defined($default) ? overload::StrVal($default) : "undef")' . - ' if defined($default);' . "\n"; + ' . $type_constraint_name . ") with " . (defined($default) ? overload::StrVal($default) : "undef");' + . "\n"; $code .= ' ' . $self->_inline_init_slot($attr, $inv, $slot_access, '$default') . "\n"; } else { diff --git a/lib/Moose/Meta/Role/Application.pm b/lib/Moose/Meta/Role/Application.pm index 74abb33..4dce63c 100644 --- a/lib/Moose/Meta/Role/Application.pm +++ b/lib/Moose/Meta/Role/Application.pm @@ -89,7 +89,7 @@ __END__ =head1 NAME -Moose::Meta::Role::Application +Moose::Meta::Role::Application - A base class for role application =head1 DESCRIPTION diff --git a/lib/Moose/Meta/Role/Application/RoleSummation.pm b/lib/Moose/Meta/Role/Application/RoleSummation.pm index 99f4771..c298bf3 100644 --- a/lib/Moose/Meta/Role/Application/RoleSummation.pm +++ b/lib/Moose/Meta/Role/Application/RoleSummation.pm @@ -230,7 +230,7 @@ __END__ =head1 NAME -Moose::Meta::Role::Application::RoleSummation +Moose::Meta::Role::Application::RoleSummation - Combine two or more roles =head1 DESCRIPTION diff --git a/lib/Moose/Meta/Role/Application/ToClass.pm b/lib/Moose/Meta/Role/Application/ToClass.pm index 05d0661..bf09f5c 100644 --- a/lib/Moose/Meta/Role/Application/ToClass.pm +++ b/lib/Moose/Meta/Role/Application/ToClass.pm @@ -179,7 +179,7 @@ __END__ =head1 NAME -Moose::Meta::Role::Application::ToClass +Moose::Meta::Role::Application::ToClass - Compose a role into a class =head1 DESCRIPTION diff --git a/lib/Moose/Meta/Role/Application/ToInstance.pm b/lib/Moose/Meta/Role/Application/ToInstance.pm index abf16a7..50e367f 100644 --- a/lib/Moose/Meta/Role/Application/ToInstance.pm +++ b/lib/Moose/Meta/Role/Application/ToInstance.pm @@ -42,7 +42,7 @@ __END__ =head1 NAME -Moose::Meta::Role::Application::ToInstance +Moose::Meta::Role::Application::ToInstance - Compose a role into an instance =head1 DESCRIPTION diff --git a/lib/Moose/Meta/Role/Application/ToRole.pm b/lib/Moose/Meta/Role/Application/ToRole.pm index 4f7ebdc..d25257b 100644 --- a/lib/Moose/Meta/Role/Application/ToRole.pm +++ b/lib/Moose/Meta/Role/Application/ToRole.pm @@ -160,7 +160,7 @@ __END__ =head1 NAME -Moose::Meta::Role::Application::ToRole +Moose::Meta::Role::Application::ToRole - Compose a role into another role =head1 DESCRIPTION diff --git a/lib/Moose/Util.pm b/lib/Moose/Util.pm index 7b18a3f..d819112 100644 --- a/lib/Moose/Util.pm +++ b/lib/Moose/Util.pm @@ -16,6 +16,8 @@ my @exports = qw[ does_role search_class_by_role apply_all_roles + get_all_init_args + get_all_attribute_values ]; Sub::Exporter::setup_exporter({ @@ -93,6 +95,27 @@ sub apply_all_roles { } } +# instance deconstruction ... + +sub get_all_attribute_values { + my ($class, $instance) = @_; + return +{ + map { $_->name => $_->get_value($instance) } + grep { $_->has_value($instance) } + $class->compute_all_applicable_attributes + }; +} + +sub get_all_init_args { + my ($class, $instance) = @_; + return +{ + map { $_->init_arg => $_->get_value($instance) } + grep { $_->has_value($instance) } + grep { defined($_->init_arg) } + $class->compute_all_applicable_attributes + }; +} + 1; @@ -151,6 +174,16 @@ actually used internally by both L and L, and the C<@roles> will be pre-processed through L to allow for the additional arguments to be passed. +=item B + +Returns the values of the C<$instance>'s fields keyed by the attribute names. + +=item B + +Returns a hash reference where the keys are all the attributes' Cs +and the values are the instance's fields. Attributes without an C +will be skipped. + =back =head1 TODO diff --git a/t/020_attributes/004_attribute_triggers.t b/t/020_attributes/004_attribute_triggers.t index b595177..0a744a5 100644 --- a/t/020_attributes/004_attribute_triggers.t +++ b/t/020_attributes/004_attribute_triggers.t @@ -17,7 +17,7 @@ BEGIN { use Moose; has 'bar' => (is => 'rw', - isa => 'Bar', + isa => 'Maybe[Bar]', trigger => sub { my ($self, $bar) = @_; $bar->foo($self) if defined $bar; diff --git a/t/040_type_constraints/023_types_and_undef.t b/t/040_type_constraints/023_types_and_undef.t new file mode 100644 index 0000000..a4b1c6e --- /dev/null +++ b/t/040_type_constraints/023_types_and_undef.t @@ -0,0 +1,119 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More tests => 55; +use Test::Exception; +use Test::Deep; + +BEGIN +{ + use_ok('Moose'); +} + +# A MOOSE OBJECT +# +{ + package Foo; + use Moose; + use Moose::Util::TypeConstraints; + + use Scalar::Util (); + + type Number + => where { defined($_) && !ref($_) && Scalar::Util::looks_like_number($_) }; + + type String + => where { defined($_) && !ref($_) && !Scalar::Util::looks_like_number($_) }; + + has vUndef => ( is => 'rw', isa => 'Undef' ); + has vDefined => ( is => 'rw', isa => 'Defined' ); + has vInt => ( is => 'rw', isa => 'Int' ); + has vNumber => ( is => 'rw', isa => 'Number' ); + has vStr => ( is => 'rw', isa => 'Str' ); + has vString => ( is => 'rw', isa => 'String' ); + + has v_lazy_Undef => ( is => 'rw', lazy => 1, default => sub { undef }, isa => 'Undef' ); + has v_lazy_Defined => ( is => 'rw', lazy => 1, default => sub { undef }, isa => 'Defined' ); + has v_lazy_Int => ( is => 'rw', lazy => 1, default => sub { undef }, isa => 'Int' ); + has v_lazy_Number => ( is => 'rw', lazy => 1, default => sub { undef }, isa => 'Number' ); + has v_lazy_Str => ( is => 'rw', lazy => 1, default => sub { undef }, isa => 'Str' ); + has v_lazy_String => ( is => 'rw', lazy => 1, default => sub { undef }, isa => 'String' ); +} + +# EXPORT TYPE CONSTRAINTS +# +Moose::Util::TypeConstraints->export_type_constraints_as_functions; + +ok( Undef(undef), '... undef is a Undef'); +ok(!Defined(undef), '... undef is NOT a Defined'); +ok(!Int(undef), '... undef is NOT a Int'); +ok(!Number(undef), '... undef is NOT a Number'); +ok(!Str(undef), '... undef is NOT a Str'); +ok(!String(undef), '... undef is NOT a String'); + +ok(!Undef(5), '... 5 is a NOT a Undef'); +ok(Defined(5), '... 5 is a Defined'); +ok(Int(5), '... 5 is a Int'); +ok(Number(5), '... 5 is a Number'); +ok(Str(5), '... 5 is a Str'); +ok(!String(5), '... 5 is NOT a String'); + +ok(!Undef(0.5), '... 0.5 is a NOT a Undef'); +ok(Defined(0.5), '... 0.5 is a Defined'); +ok(!Int(0.5), '... 0.5 is NOT a Int'); +ok(Number(0.5), '... 0.5 is a Number'); +ok(Str(0.5), '... 0.5 is a Str'); +ok(!String(0.5), '... 0.5 is NOT a String'); + +ok(!Undef('Foo'), '... "Foo" is NOT a Undef'); +ok(Defined('Foo'), '... "Foo" is a Defined'); +ok(!Int('Foo'), '... "Foo" is NOT a Int'); +ok(!Number('Foo'), '... "Foo" is NOT a Number'); +ok(Str('Foo'), '... "Foo" is a Str'); +ok(String('Foo'), '... "Foo" is a String'); + + +my $foo = Foo->new; + +lives_ok { $foo->vUndef(undef) } '... undef is a Foo->Undef'; +dies_ok { $foo->vDefined(undef) } '... undef is NOT a Foo->Defined'; +dies_ok { $foo->vInt(undef) } '... undef is NOT a Foo->Int'; +dies_ok { $foo->vNumber(undef) } '... undef is NOT a Foo->Number'; +dies_ok { $foo->vStr(undef) } '... undef is NOT a Foo->Str'; +dies_ok { $foo->vString(undef) } '... undef is NOT a Foo->String'; + +dies_ok { $foo->vUndef(5) } '... 5 is NOT a Foo->Undef'; +lives_ok { $foo->vDefined(5) } '... 5 is a Foo->Defined'; +lives_ok { $foo->vInt(5) } '... 5 is a Foo->Int'; +lives_ok { $foo->vNumber(5) } '... 5 is a Foo->Number'; +lives_ok { $foo->vStr(5) } '... 5 is a Foo->Str'; +dies_ok { $foo->vString(5) } '... 5 is NOT a Foo->String'; + +dies_ok { $foo->vUndef(0.5) } '... 0.5 is NOT a Foo->Undef'; +lives_ok { $foo->vDefined(0.5) } '... 0.5 is a Foo->Defined'; +dies_ok { $foo->vInt(0.5) } '... 0.5 is NOT a Foo->Int'; +lives_ok { $foo->vNumber(0.5) } '... 0.5 is a Foo->Number'; +lives_ok { $foo->vStr(0.5) } '... 0.5 is a Foo->Str'; +dies_ok { $foo->vString(0.5) } '... 0.5 is NOT a Foo->String'; + +dies_ok { $foo->vUndef('Foo') } '... "Foo" is NOT a Foo->Undef'; +lives_ok { $foo->vDefined('Foo') } '... "Foo" is a Foo->Defined'; +dies_ok { $foo->vInt('Foo') } '... "Foo" is NOT a Foo->Int'; +dies_ok { $foo->vNumber('Foo') } '... "Foo" is NOT a Foo->Number'; +lives_ok { $foo->vStr('Foo') } '... "Foo" is a Foo->Str'; +lives_ok { $foo->vString('Foo') } '... "Foo" is a Foo->String'; + +# the lazy tests + +lives_ok { $foo->v_lazy_Undef() } '... undef is a Foo->Undef'; +dies_ok { $foo->v_lazy_Defined() } '... undef is NOT a Foo->Defined'; +dies_ok { $foo->v_lazy_Int() } '... undef is NOT a Foo->Int'; +dies_ok { $foo->v_lazy_Number() } '... undef is NOT a Foo->Number'; +dies_ok { $foo->v_lazy_Str() } '... undef is NOT a Foo->Str'; +dies_ok { $foo->v_lazy_String() } '... undef is NOT a Foo->String'; + + + + diff --git a/t/060_compat/003_foreign_inheritence.t b/t/060_compat/003_foreign_inheritence.t index 5442e3f..2b9751c 100644 --- a/t/060_compat/003_foreign_inheritence.t +++ b/t/060_compat/003_foreign_inheritence.t @@ -81,6 +81,11 @@ lives_ok { Old::Bucket::Nose->meta->make_immutable(debug => 0); } 'Immutability on Moose class extending Class::MOP class ok'; -lives_ok { - SubClass2::extends('MyBase'); -} 'Can subclass the same non-Moose class twice with different metaclasses'; +TODO: { + local $TODO = 'Needs MRO::Compat support'; + + lives_ok { + SubClass2::extends('MyBase'); + } 'Can subclass the same non-Moose class twice with different metaclasses'; + +}