From: gfx Date: Tue, 22 Sep 2009 01:37:00 +0000 (+0900) Subject: Change, Fix, Improve X-Git-Tag: 0.32~18 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?p=gitmo%2FMouse.git;a=commitdiff_plain;h=7b133c927969b2e9233a51c6be5caed54c88915e Change, Fix, Improve --- diff --git a/Changes b/Changes index 84ba3cb..a0b7309 100644 --- a/Changes +++ b/Changes @@ -2,9 +2,13 @@ Revision history for Mouse 0.31 + * Remove Test::Mouse, which was accidentally included (gfx) + + * Add find_meta() and does_role() to Mouse::Util (gfx) + 0.30 Mon Sep 21 16:43:05 2009 - * Implement RT #46930 (accessor/reader/writer in has()) + * Implement RT #46930 (accessor/reader/writer in has()) (gfx) * Work around anonymous classes as mortal classes (gfx) diff --git a/Makefile.PL b/Makefile.PL index a54311c..2449420 100755 --- a/Makefile.PL +++ b/Makefile.PL @@ -44,8 +44,6 @@ sub create_moose_compatibility_test { # some test does not pass... currently skip it. my %SKIP_TEST = ( '016-trigger.t' => "trigger's argument is incompatble :(", -# '020-load-class.t' => "&Moose::is_class_loaded doesn't exists", - '019-handles.t' => 'incompatible', '029-new.t' => 'Class->new(undef) incompatible', '010-isa-or.t' => 'Mouse has a [BUG]', '044-attribute-metaclass.t' => 'Moose::Meta::Attribute does not have a "create"', diff --git a/lib/Mouse/Meta/Attribute.pm b/lib/Mouse/Meta/Attribute.pm index e3cf769..77d935a 100644 --- a/lib/Mouse/Meta/Attribute.pm +++ b/lib/Mouse/Meta/Attribute.pm @@ -2,7 +2,6 @@ package Mouse::Meta::Attribute; use strict; use warnings; -use Scalar::Util (); use Mouse::Meta::TypeConstraint; use Mouse::Meta::Method::Accessor; @@ -76,12 +75,6 @@ sub _create_args { sub accessor_metaclass { 'Mouse::Meta::Method::Accessor' } -sub _inlined_name { - my $self = shift; - return sprintf '"%s"', quotemeta $self->name; -} - - sub create { my ($self, $class, $name, %args) = @_; diff --git a/lib/Mouse/Meta/Method/Accessor.pm b/lib/Mouse/Meta/Method/Accessor.pm index 56478d7..3ae91a8 100755 --- a/lib/Mouse/Meta/Method/Accessor.pm +++ b/lib/Mouse/Meta/Method/Accessor.pm @@ -1,6 +1,7 @@ package Mouse::Meta::Method::Accessor; use strict; use warnings; +use Scalar::Util qw(blessed); sub _install_accessor{ my (undef, $attribute, $method_name, $class, $type) = @_; @@ -17,7 +18,7 @@ sub _install_accessor{ my $compiled_type_constraint = $constraint ? $constraint->{_compiled_type_constraint} : undef; my $self = '$_[0]'; - my $key = $attribute->_inlined_name; + my $key = sprintf q{"%s"}, quotemeta $name; $type ||= 'accessor'; @@ -140,54 +141,54 @@ sub _install_writer{ sub _install_predicate { my (undef, $attribute, $method_name, $class) = @_; - my $key = $attribute->_inlined_name; + my $slot = $attribute->name; - my $predicate = 'sub { exists($_[0]->{'.$key.'}) }'; - - my $code = eval $predicate; - $attribute->throw_error($@) if $@; - $class->add_method($method_name => $code); + $class->add_method($method_name => sub{ + return exists $_[0]->{$slot}; + }); return; } sub _install_clearer { my (undef, $attribute, $method_name, $class) = @_; - my $key = $attribute->_inlined_name; - - my $clearer = 'sub { delete($_[0]->{'.$key.'}) }'; + my $slot = $attribute->name; - my $code = eval $clearer; - $attribute->throw_error($@) if $@; - $class->add_method($method_name => $code); + $class->add_method($method_name => sub{ + delete $_[0]->{$slot}; + }); return; } sub _install_handles { my (undef, $attribute, $handles, $class) = @_; - my $reader = $attribute->name; - my %handles = $attribute->_canonicalize_handles($handles); + my $reader = $attribute->reader || $attribute->accessor + or $class->throw_error("You must pass a reader method for '".$attribute->name."'"); - my @methods; - - foreach my $local_method (keys %handles) { - my $remote_method = $handles{$local_method}; - - my $method = 'sub { - my $self = shift; - $self->'.$reader.'->'.$remote_method.'(@_) - }'; - - my $code = eval $method; - $attribute->throw_error($@) if $@; - - push @methods, ($local_method => $code); - } + my %handles = $attribute->_canonicalize_handles($handles); - # install after all the method compiled successfully - while(my($name, $code) = splice @methods, 0, 2){ - $class->add_method($name, $code); + foreach my $handle_name (keys %handles) { + my $method_to_call = $handles{$handle_name}; + + my $code = sub { + my $instance = shift; + my $proxy = $instance->$reader(); + + my $error = !defined($proxy) ? ' is not defined' + : ref($proxy) && !blessed($proxy) ? qq{ is not an object (got '$proxy')} + : undef; + if ($error) { + $instance->meta->throw_error( + "Cannot delegate $handle_name to $method_to_call because " + . "the value of " + . $attribute->name + . $error, + ); + } + $proxy->$method_to_call(@_); + }; + $class->add_method($handle_name => $code); } return; } diff --git a/t/019-handles.t b/t/019-handles.t index 03797d6..47abf58 100644 --- a/t/019-handles.t +++ b/t/019-handles.t @@ -1,7 +1,8 @@ #!/usr/bin/env perl use strict; use warnings; -use Test::More tests => 24; +use Test::More tests => 26; +use Test::Exception; do { package Person; @@ -117,3 +118,13 @@ is_deeply( "correct handles layout for 'person'", ); +throws_ok{ + $object->person(undef); + $object->person_name(); +} qr/Cannot delegate person_name to name because the value of person is not defined/; + +throws_ok{ + $object->person([]); + $object->person_age(); +} qr/Cannot delegate person_age to age because the value of person is not an object/; + diff --git a/t/400-define-role.t b/t/400-define-role.t index 47ac4ee..1cb7397 100644 --- a/t/400-define-role.t +++ b/t/400-define-role.t @@ -1,7 +1,15 @@ #!/usr/bin/env perl use strict; use warnings; -use Test::More tests => 11; +use Test::More; +BEGIN{ + if(eval{ require Class::Method::Modifiers::Fast } || eval{ require Class::Method::Modifiers }){ + plan tests => 11; + } + else{ + plan skip_all => 'This test requires Class::Method::Modifiers(::Fast)?'; + } +} use Test::Exception; lives_ok {