From: Hans Dieter Pearcey <hdp@weftsoar.net>
Date: Thu, 25 Jun 2009 21:24:51 +0000 (-0400)
Subject: slightly better test failures
X-Git-Tag: 0.89_02~129
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=5404f169478751c007adfd192e2a42eb1a44206b;p=gitmo%2FMoose.git

slightly better test failures
---

diff --git a/lib/Moose/AttributeHelpers/Meta/Method/Delegation.pm b/lib/Moose/AttributeHelpers/Meta/Method/Delegation.pm
new file mode 100644
index 0000000..374e06b
--- /dev/null
+++ b/lib/Moose/AttributeHelpers/Meta/Method/Delegation.pm
@@ -0,0 +1,51 @@
+package Moose::AttributeHelpers::Meta::Method::Delegation;
+use Moose;
+
+our $VERSION   = '0.19';
+$VERSION = eval $VERSION;
+our $AUTHORITY = 'cpan:STEVAN';
+
+extends 'Moose::Meta::Method::Delegation';
+
+1;
+
+__END__
+
+=pod
+
+=head1 NAME
+
+Moose::AttributeHelpers::Meta::Method::Delegation
+
+=head1 DESCRIPTION
+
+This is an extension of Moose::Meta::Method to mark I<handled> methods.
+
+=head1 METHODS
+
+=over 4
+
+=item B<meta>
+
+=back
+
+=head1 BUGS
+
+All complex software has bugs lurking in it, and this module is no
+exception. If you find a bug please either email me, or add the bug
+to cpan-RT.
+
+=head1 AUTHOR
+
+Stevan Little E<lt>stevan@iinteractive.comE<gt>
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright 2007-2009 by Infinity Interactive, Inc.
+
+L<http://www.iinteractive.com>
+
+This library is free software; you can redistribute it and/or modify
+it under the same terms as Perl itself.
+
+=cut
diff --git a/lib/Moose/AttributeHelpers/Trait/Base.pm b/lib/Moose/AttributeHelpers/Trait/Base.pm
index 9caf4d6..573ccb9 100644
--- a/lib/Moose/AttributeHelpers/Trait/Base.pm
+++ b/lib/Moose/AttributeHelpers/Trait/Base.pm
@@ -2,6 +2,7 @@
 package Moose::AttributeHelpers::Trait::Base;
 use Moose::Role;
 use Moose::Util::TypeConstraints;
+use Moose::AttributeHelpers::Meta::Method::Delegation;
 
 our $VERSION   = '0.19';
 $VERSION = eval $VERSION;
@@ -62,79 +63,50 @@ sub process_options_for_handles {
     }
 }
 
+sub delegation_metaclass {
+    'Moose::AttributeHelpers::Meta::Method::Delegation'
+}
+
 before '_process_options' => sub {
     my ($self, $name, $options) = @_;
     $self->process_options_for_handles($options, $name);
 };
 
+around '_canonicalize_handles' => sub {
+    my $next    = shift;
+    my $self    = shift;
+    my $handles = $self->handles;
+    return unless $handles;
+    unless ('HASH' eq ref $handles) {
+        $self->throw_error(
+            "The 'handles' option must be a HASH reference, not $handles"
+        );
+    }
+    return map {
+        my $to = $handles->{$_};
+        $to = [ $to ] unless ref $to;
+        $_ => $to
+    } keys %$handles;
+};
+
 ## methods called after instantiation
 
+before 'install_delegation' => sub { (shift)->check_handles_values };
+
 sub check_handles_values {
     my $self = shift;
 
     my $method_constructors = $self->method_constructors;
 
-    foreach my $key (keys %{$self->handles}) {
-        (exists $method_constructors->{$key})
-            || confess "$key is an unsupported method type";
-    }
-
-}
-
-after 'install_accessors' => sub {
-    my $attr  = shift;
-    my $class = $attr->associated_class;
-
-    # grab the reader and writer methods
-    # as well, this will be useful for
-    # our method provider constructors
-    my $attr_reader = $attr->get_read_method_ref;
-    my $attr_writer = $attr->get_write_method_ref;
-
-    # before we install them, lets
-    # make sure they are valid
-    $attr->check_handles_values;
+    my %handles = $self->_canonicalize_handles;
 
-    my $method_constructors = $attr->method_constructors;
-
-    my $class_name = $class->name;
-
-    foreach my $key (keys %{$attr->handles}) {
-
-        my $method_name = $attr->handles->{$key};
-
-        if ($class->has_method($method_name)) {
-            confess "The method ($method_name) already exists in class (" . $class->name . ")";
-        }
-
-        my $method = Moose::AttributeHelpers::Meta::Method::Provided->wrap(
-            $method_constructors->{$key}->(
-                $attr,
-                $attr_reader,
-                $attr_writer,
-            ),
-            package_name => $class_name,
-            name => $method_name,
-        );
-
-        $attr->associate_method($method);
-        $class->add_method($method_name => $method);
+    for my $original_method (values %handles) {
+        my $name = $original_method->[0];
+        (exists $method_constructors->{$name})
+            || confess "$name is an unsupported method type";
     }
-};
 
-after 'remove_accessors' => sub {
-    my $attr  = shift;
-    my $class = $attr->associated_class;
-
-    # provides accessors
-    foreach my $key (keys %{$attr->handles}) {
-        my $method_name = $attr->handles->{$key};
-        my $method = $class->get_method($method_name);
-        $class->remove_method($method_name)
-            if blessed($method) &&
-               $method->isa('Moose::AttributeHelpers::Meta::Method::Provided');
-    }
-};
+}
 
 no Moose::Role;
 no Moose::Util::TypeConstraints;
diff --git a/lib/Moose/AttributeHelpers/Trait/Counter.pm b/lib/Moose/AttributeHelpers/Trait/Counter.pm
index f4aba28..218f25a 100644
--- a/lib/Moose/AttributeHelpers/Trait/Counter.pm
+++ b/lib/Moose/AttributeHelpers/Trait/Counter.pm
@@ -33,14 +33,14 @@ before 'process_options_for_handles' => sub {
 
 after 'check_handles_values' => sub {
     my $self     = shift;
-    my $provides = $self->provides;
+    my $handles = $self->handles;
 
-    unless (scalar keys %$provides) {
+    unless (scalar keys %$handles) {
         my $method_constructors = $self->method_constructors;
         my $attr_name           = $self->name;
 
         foreach my $method (keys %$method_constructors) {
-            $provides->{$method} = ($method . '_' . $attr_name);
+            $handles->{$method} = ($method . '_' . $attr_name);
         }
     }
 };