From: Tokuhiro Matsuno <tokuhirom@gp.ath.cx>
Date: Tue, 2 Dec 2008 06:36:50 +0000 (+0000)
Subject: support alias option on 'with'
X-Git-Tag: 0.19~136^2~88
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=4aaa2ed6a8f267aa74bfbbab9b6880a900ca6063;p=gitmo%2FMouse.git

support alias option on 'with'
---

diff --git a/lib/Mouse.pm b/lib/Mouse.pm
index 380d9b2..f4cdfe0 100644
--- a/lib/Mouse.pm
+++ b/lib/Mouse.pm
@@ -69,11 +69,12 @@ sub with {
     my $meta = Mouse::Meta::Class->initialize(caller);
 
     my $role  = shift;
+    my $args  = shift || {};
 
-    confess "Mouse::Role only supports 'with' on individual roles at a time" if @_;
+    confess "Mouse::Role only supports 'with' on individual roles at a time" if @_ || !ref $args;
 
     Mouse::load_class($role);
-    $role->meta->apply($meta);
+    $role->meta->apply($meta, %$args);
 }
 
 sub import {
diff --git a/lib/Mouse/Meta/Role.pm b/lib/Mouse/Meta/Role.pm
index 9072312..0e1d667 100644
--- a/lib/Mouse/Meta/Role.pm
+++ b/lib/Mouse/Meta/Role.pm
@@ -72,10 +72,13 @@ sub apply {
     my $selfname = $self->name;
     my $class = shift;
     my $classname = $class->name;
+    my %args  = @_;
 
-    for my $name (@{$self->{required_methods}}) {
-        unless ($classname->can($name)) {
-            confess "'$selfname' requires the method '$name' to be implemented by '$classname'";
+    if ($class->isa('Mouse::Meta::Class')) {
+        for my $name (@{$self->{required_methods}}) {
+            unless ($classname->can($name)) {
+                confess "'$selfname' requires the method '$name' to be implemented by '$classname'";
+            }
         }
     }
 
@@ -83,11 +86,12 @@ sub apply {
         no strict 'refs';
         for my $name ($self->get_method_list) {
             next if $name eq 'has' || $name eq 'requires' || $name eq 'meta' || $name eq 'with' || $name eq 'around' || $name eq 'before' || $name eq 'after' || $name eq 'blessed' || $name eq 'extends' || $name eq 'confess' || $name eq 'excludes';
-            if ($classname->can($name)) {
+            my $dstname = $args{alias} ? ($args{alias}->{$name}||$name) : $name;
+            if ($classname->can($dstname)) {
                 # XXX what's Moose's behavior?
                 next;
             }
-            *{"${classname}::${name}"} = *{"${selfname}::${name}"};
+            *{"${classname}::${dstname}"} = *{"${selfname}::${name}"};
         }
     }
 
diff --git a/lib/Mouse/Role.pm b/lib/Mouse/Role.pm
index b222a1d..ec74bcc 100644
--- a/lib/Mouse/Role.pm
+++ b/lib/Mouse/Role.pm
@@ -52,10 +52,11 @@ sub extends  { confess "Roles do not support 'extends'" }
 sub with     {
     my $meta = Mouse::Meta::Role->initialize(caller);
     my $role  = shift;
-    confess "Mouse::Role only supports 'with' on individual roles at a time" if @_;
+    my $args  = shift || {};
+    confess "Mouse::Role only supports 'with' on individual roles at a time" if @_ || !ref $args;
 
     Mouse::load_class($role);
-    $role->meta->apply($meta);
+    $role->meta->apply($meta, %$args);
 }
 
 sub requires {
diff --git a/t/035-apply-roles-to-roles.t b/t/035-apply-roles-to-roles.t
index a6842d5..bae8e0e 100644
--- a/t/035-apply-roles-to-roles.t
+++ b/t/035-apply-roles-to-roles.t
@@ -1,10 +1,11 @@
 use strict;
 use warnings;
-use Test::More tests => 4;
+use Test::More tests => 5;
 
 {
     package Animal;
     use Mouse::Role;
+    requires 'bark';
     sub eat { 'delicious' }
     has food => ( is => 'ro' );
 }
@@ -19,6 +20,7 @@ use Test::More tests => 4;
     package Chihuahua;
     use Mouse;
     with 'Dog';
+    sub bark { 'bow-wow' }
 }
 
 ok !Animal->can('food');
@@ -27,4 +29,5 @@ ok !Dog->can('food');
 my $c = Chihuahua->new(food => 'bone');
 is $c->eat(), 'delicious';
 is $c->food(), 'bone';
+is $c->bark(), 'bow-wow';
 
diff --git a/t/036-with-method-alias.t b/t/036-with-method-alias.t
new file mode 100644
index 0000000..c1976ab
--- /dev/null
+++ b/t/036-with-method-alias.t
@@ -0,0 +1,43 @@
+use strict;
+use warnings;
+use Test::More tests => 5;
+
+{
+    package Animal;
+    use Mouse::Role;
+    sub eat { 'delicious' }
+}
+
+{
+    package Cat;
+    use Mouse::Role;
+    with 'Animal', {
+        alias => { eat => 'drink' },
+    };
+    sub eat { 'good!' }
+}
+
+{
+    package Tama;
+    use Mouse;
+    with 'Cat';
+}
+
+{
+    package Dog;
+    use Mouse;
+    with 'Animal', {
+        alias => { eat => 'drink' }
+    };
+}
+
+ok(!Dog->can('eat'));
+ok(Dog->can('drink'));
+
+my $d = Dog->new();
+is($d->drink(), 'delicious');
+
+my $t = Tama->new;
+is $t->drink(), 'delicious';
+is $t->eat(),    'good!';
+