From: Matt S Trout <mst@shadowcat.co.uk>
Date: Sat, 6 Nov 2010 20:32:26 +0000 (+0000)
Subject: clean up, add with and ->does
X-Git-Tag: 0.009001~79
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=5a2474061ed05c0a95a4cfb299865bc752d7675d;p=gitmo%2FMoo.git

clean up, add with and ->does
---

diff --git a/lib/Role/Tiny.pm b/lib/Role/Tiny.pm
index 8d8d016..7883099 100644
--- a/lib/Role/Tiny.pm
+++ b/lib/Role/Tiny.pm
@@ -6,19 +6,25 @@ use Class::Method::Modifiers ();
 our %INFO;
 our %APPLIED_TO;
 
+sub _getglob { no strict 'refs'; \*{$_[0]} }
+
 sub import {
   my $target = caller;
   # get symbol table reference
   my $stash = do { no strict 'refs'; \%{"${target}::"} };
   # install before/after/around subs
   foreach my $type (qw(before after around)) {
-    *{(do { no strict 'refs'; \*{"${target}::${type}"}})} = sub {
+    *{_getglob "${target}::${type}"} = sub {
       push @{$INFO{$target}{modifiers}||=[]}, [ $type => @_ ];
     };
   }
-  *{(do { no strict 'refs'; \*{"${target}::requires"}})} = sub {
+  *{_getglob "${target}::requires"} = sub {
     push @{$INFO{$target}{requires}||=[]}, @_;
   };
+  *{_getglob "${target}::with"} = sub {
+    die "Only one role supported at a time by with" if @_ > 1;
+    Role::Tiny->apply_role_to_package($_[0], $target);
+  };
   # grab all *non-constant* (ref eq 'SCALAR') subs present
   # in the symbol table and store their refaddrs (no need to forcibly
   # inflate constant subs into real subs) - also add '' to here (this
@@ -68,14 +74,19 @@ sub apply_role_to_package {
   my @to_install = grep !exists $has_methods{$_}, keys %$methods;
   foreach my $i (@to_install) {
     no warnings 'once';
-    *{(do { no strict 'refs'; \*{"${to}::$i"}})}
-      = $methods->{$i};
+    *{_getglob "${to}::${i}"} = $methods->{$i};
   }
 
   foreach my $modifier (@{$info->{modifiers}||[]}) {
     Class::Method::Modifiers::install_modifier($to, @{$modifier});
   }
 
+  # only add does() method to classes and only if they don't have one
+  if (not $INFO{$to} and not $to->can('does')) {
+    ${_getglob "${to}::does"} = \&does_role;
+  }
+    
+
   # copy our role list into the target's
   @{$APPLIED_TO{$to}||={}}{keys %{$APPLIED_TO{$role}}} = ();
 }
diff --git a/t/simple.t b/t/simple.t
index ea5bb53..c0043dd 100644
--- a/t/simple.t
+++ b/t/simple.t
@@ -43,6 +43,8 @@ is(try_apply_to('MyClass'), undef, 'role applies cleanly');
 is(MyClass->foo, 'role foo class foo', 'method modifier');
 is(MyClass->bar, 'role bar', 'method from role');
 is(MyClass->baz, 'class baz', 'method from class');
+ok(MyClass->does('MyRole'), 'class does role');
+ok(!MyClass->does('Random'), 'class does not do non-role');
 
 like(try_apply_to('NoMethods'), qr/req1, req2/, 'error for both methods');
 like(try_apply_to('OneMethod'), qr/req2/, 'error for one method');