From: Tokuhiro Matsuno <tokuhirom@gp.ath.cx>
Date: Tue, 2 Dec 2008 04:01:08 +0000 (+0000)
Subject: support requires on Mouse::Role.
X-Git-Tag: 0.19~136^2~91
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=59089ec36675c7df1998945b1446c37794f88306;p=gitmo%2FMouse.git

support requires on Mouse::Role.
---

diff --git a/lib/Mouse/Meta/Role.pm b/lib/Mouse/Meta/Role.pm
index 07203c3..ebb929f 100644
--- a/lib/Mouse/Meta/Role.pm
+++ b/lib/Mouse/Meta/Role.pm
@@ -2,6 +2,7 @@
 package Mouse::Meta::Role;
 use strict;
 use warnings;
+use Carp 'confess';
 
 do {
     my %METACLASS_CACHE;
@@ -27,13 +28,20 @@ sub new {
     my $class = shift;
     my %args  = @_;
 
-    $args{attributes} ||= {};
+    $args{attributes}       ||= {};
+    $args{required_methods} ||= [];
 
     bless \%args, $class;
 }
 
 sub name { $_[0]->{name} }
 
+sub add_required_methods {
+    my $self = shift;
+    my @methods = @_;
+    push @{$self->{required_methods}}, @methods;
+}
+
 sub add_attribute {
     my $self = shift;
     my $name = shift;
@@ -49,6 +57,12 @@ sub apply {
     my $self  = shift;
     my $class = shift;
 
+    for my $name (@{$self->{required_methods}}) {
+        unless ($class->name->can($name)) {
+            confess "'@{[ $self->name ]}' requires the method '$name' to be implemented by '@{[ $class->name ]}'";
+        }
+    }
+
     for my $name ($self->get_attribute_list) {
         next if $class->has_attribute($name);
         my $spec = $self->get_attribute($name);
diff --git a/lib/Mouse/Role.pm b/lib/Mouse/Role.pm
index 2f44a75..057761a 100644
--- a/lib/Mouse/Role.pm
+++ b/lib/Mouse/Role.pm
@@ -51,7 +51,11 @@ sub extends  { confess "Roles do not support 'extends'" }
 
 sub with     { confess "Mouse::Role does not currently support 'with'" }
 
-sub requires { confess "Mouse::Role does not currently support 'requires'" }
+sub requires {
+    my $meta = Mouse::Meta::Role->initialize(caller);
+    Carp::croak "Must specify at least one method" unless @_;
+    $meta->add_required_methods(@_);
+}
 
 sub excludes { confess "Mouse::Role does not currently support 'excludes'" }
 
diff --git a/t/033-requires.t b/t/033-requires.t
new file mode 100644
index 0000000..da4f10f
--- /dev/null
+++ b/t/033-requires.t
@@ -0,0 +1,25 @@
+#!perl
+use strict;
+use warnings;
+use Test::More tests => 1;
+use Mouse::Util ':test';
+
+{
+    package Foo;
+    use Mouse::Role;
+    requires 'foo';
+}
+
+throws_ok {
+    package Bar;
+    use Mouse;
+    with 'Foo';
+} qr/'Foo' requires the method 'foo' to be implemented by 'Bar'/;
+
+{
+    package Baz;
+    use Mouse;
+    with 'Foo';
+    sub foo { }
+}
+
diff --git a/t/400-define-role.t b/t/400-define-role.t
index 66cddb0..aa7f598 100644
--- a/t/400-define-role.t
+++ b/t/400-define-role.t
@@ -1,7 +1,7 @@
 #!/usr/bin/env perl
 use strict;
 use warnings;
-use Test::More tests => 12;
+use Test::More tests => 11;
 use Mouse::Util ':test';
 
 lives_ok {
@@ -68,15 +68,6 @@ throws_ok {
     package Role;
     use Mouse::Role;
 
-    requires 'required';
-
-    no Mouse::Role;
-} qr/Mouse::Role does not currently support 'requires'/;
-
-throws_ok {
-    package Role;
-    use Mouse::Role;
-
     excludes 'excluded';
 
     no Mouse::Role;