Making 'handles' accept regexes in the arrayref.

The arrayref form of 'handles' accepts regular expression elements to
extend the method name list with their matches.
The elements in the arrayref form of 'handles' are made unique.

diff --git a/Changes b/Changes
index e6ded8e..8a038f5 100644 (file)
--- a/Changes
+++ b/Changes
@@ -7,6 +7,10 @@ for, noteworthy changes.
     * Moose::Util::TypeConstraints
       - Changed Str constraint to accept magic lvalue strings like one gets
         from substr et al, again. (sorear)
+    * Moose::Meta::Attribute
+      - The elements in the arrayref form of 'handles' are made unique. (norbi)
+      - The arrayref form of 'handles' accepts regular expression elements to
+       extend the method name list with their matches. (norbi)
 
 0.93 Thu, Nov 19, 2009
     * Moose::Object

diff --git a/lib/Moose.pm b/lib/Moose.pm
index 6c9f6c7..6082236 100644 (file)
--- a/lib/Moose.pm
+++ b/lib/Moose.pm
@@ -515,6 +515,13 @@ This is the most common usage for I<handles>. You basically pass a list of
 method names to be delegated, and Moose will install a delegation method
 for each one.
 
+You can also include regular expressions in the arrayref to extend the list
+with the methods (of the class being delegated to) whose names are matched by
+the regular expressions. A method name is included if it is present in the
+arrayref as a string, or if at least one regular expression matches it. See the
+C<REGEX> format below for more details about how the regular expressions are
+interpreted and the limitations they impose.
+
 =item C<HASH>
 
 This is the second most common usage for I<handles>. Instead of a list of
@@ -1177,6 +1184,8 @@ Cory (gphat) Watson
 
 Dylan Hardison (doc fixes)
 
+Norbert (norbi) Buchmuller
+
 ... and many other #moose folks
 
 =head1 COPYRIGHT AND LICENSE

diff --git a/lib/Moose/Meta/Attribute.pm b/lib/Moose/Meta/Attribute.pm
index 92dc684..047d585 100644 (file)
--- a/lib/Moose/Meta/Attribute.pm
+++ b/lib/Moose/Meta/Attribute.pm
@@ -5,7 +5,7 @@ use strict;
 use warnings;
 
 use Scalar::Util 'blessed', 'weaken';
-use List::MoreUtils 'any';
+use List::MoreUtils 'any', 'uniq', 'part';
 use Try::Tiny;
 use overload     ();
 
@@ -675,7 +675,19 @@ sub _canonicalize_handles {
             return %{$handles};
         }
         elsif ($handle_type eq 'ARRAY') {
-            return map { $_ => $_ } @{$handles};
+            my ($strings, $regexes) = part { ref $_ eq 'Regexp' } @{$handles};
+
+            my @method_names = @{ $strings || [] };
+            if ($regexes) {
+                ($self->has_type_constraint)
+                    || $self->throw_error("Cannot delegate methods based on a Regexp without a type constraint (isa)", data => $handles);
+                foreach my $regex (@{$regexes}) {
+                    push @method_names,
+                        grep { /$regex/ } $self->_get_delegate_method_list;
+                }
+            }
+
+            return map { $_ => $_ } uniq @method_names;
         }
         elsif ($handle_type eq 'Regexp') {
             ($self->has_type_constraint)

diff --git a/t/020_attributes/010_attribute_delegation.t b/t/020_attributes/010_attribute_delegation.t
index 95bd73c..d28c6b5 100644 (file)
--- a/t/020_attributes/010_attribute_delegation.t
+++ b/t/020_attributes/010_attribute_delegation.t
@@ -3,7 +3,7 @@
 use strict;
 use warnings;
 
-use Test::More tests => 92;
+use Test::More tests => 119;
 use Test::Exception;
 
 
@@ -132,6 +132,105 @@ is($car->go, 'Engine::go', '... got the right value from ->go');
 is($car->stop, 'Engine::stop', '... got the right value from ->stop');
 
 # -------------------------------------------------------------------
+# ARRAY+REGEXP handles
+# -------------------------------------------------------------------
+# the array based format can also contain regexes
+
+{
+    package Thud;
+    use Moose;
+
+    sub foo  { 'Thud::foo'  }
+    sub bar  { 'Thud::bar'  }
+    sub baz  { 'Thud::baz'  }
+    sub quux { 'Thud::quux' }
+
+    package Thud::Proxy1;
+    use Moose;
+
+    has 'thud' => (
+        is      => 'ro',
+        isa     => 'Thud',
+        default => sub { Thud->new },
+        handles => [
+          qr/^b.*/,
+        ],
+    );
+
+    package Thud::Proxy2;
+    use Moose;
+
+    has 'thud' => (
+        is      => 'ro',
+        isa     => 'Thud',
+        default => sub { Thud->new },
+        handles => [
+          'quux',
+          qr/^b.*/,
+        ],
+    );
+
+    package Thud::Proxy3;
+    use Moose;
+
+    has 'thud' => (
+        is      => 'ro',
+        isa     => 'Thud',
+        default => sub { Thud->new },
+        handles => [
+          qr/.*/,
+          'quux',
+        ],
+    );
+}
+
+{
+    my $thud_proxy = Thud::Proxy1->new;
+    isa_ok($thud_proxy, 'Thud::Proxy1');
+
+    can_ok($thud_proxy, 'thud');
+    isa_ok($thud_proxy->thud, 'Thud');
+
+    can_ok($thud_proxy, 'bar');
+    can_ok($thud_proxy, 'baz');
+
+    is($thud_proxy->bar, 'Thud::bar', '... got the right proxied return value');
+    is($thud_proxy->baz, 'Thud::baz', '... got the right proxied return value');
+}
+{
+    my $thud_proxy = Thud::Proxy2->new;
+    isa_ok($thud_proxy, 'Thud::Proxy2');
+
+    can_ok($thud_proxy, 'thud');
+    isa_ok($thud_proxy->thud, 'Thud');
+
+    can_ok($thud_proxy, 'bar');
+    can_ok($thud_proxy, 'baz');
+    can_ok($thud_proxy, 'quux');
+
+    is($thud_proxy->bar, 'Thud::bar', '... got the right proxied return value');
+    is($thud_proxy->baz, 'Thud::baz', '... got the right proxied return value');
+    is($thud_proxy->quux, 'Thud::quux', '... got the right proxied return value');
+}
+{
+    my $thud_proxy = Thud::Proxy3->new;
+    isa_ok($thud_proxy, 'Thud::Proxy3');
+
+    can_ok($thud_proxy, 'thud');
+    isa_ok($thud_proxy->thud, 'Thud');
+
+    can_ok($thud_proxy, 'foo');
+    can_ok($thud_proxy, 'bar');
+    can_ok($thud_proxy, 'baz');
+    can_ok($thud_proxy, 'quux');
+
+    is($thud_proxy->foo, 'Thud::foo', '... got the right proxied return value');
+    is($thud_proxy->bar, 'Thud::bar', '... got the right proxied return value');
+    is($thud_proxy->baz, 'Thud::baz', '... got the right proxied return value');
+    is($thud_proxy->quux, 'Thud::quux', '... got the right proxied return value');
+}
+
+# -------------------------------------------------------------------
 # REGEXP handles
 # -------------------------------------------------------------------
 # and we support regexp delegation