Change, Fix, Improve

diff --git a/Changes b/Changes
index 84ba3cb..a0b7309 100644 (file)
--- 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 (executable)
--- 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 (file)
--- 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 (executable)
--- 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 {\r
+            my $instance = shift;\r
+            my $proxy    = $instance->$reader();\r
+\r
+            my $error = !defined($proxy)                ? ' is not defined'\r
+                      : ref($proxy) && !blessed($proxy) ? qq{ is not an object (got '$proxy')}\r
+                                                        : undef;\r
+            if ($error) {\r
+                $instance->meta->throw_error(\r
+                    "Cannot delegate $handle_name to $method_to_call because "\r
+                        . "the value of "\r
+                        . $attribute->name\r
+                        . $error,
+                 );\r
+            }\r
+            $proxy->$method_to_call(@_);\r
+        };
+        $class->add_method($handle_name => $code);
     }
     return;
 }

diff --git a/t/019-handles.t b/t/019-handles.t
index 03797d6..47abf58 100644 (file)
--- 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 (file)
--- 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 {