From: Matt S Trout <mst@shadowcat.co.uk>
Date: Sat, 6 Nov 2010 20:26:07 +0000 (+0000)
Subject: basic Role::Tiny code
X-Git-Tag: 0.009001~80
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=ab3370e78cdd2175285cb06ea8aa3702308713ea;p=gitmo%2FRole-Tiny.git

basic Role::Tiny code
---

ab3370e78cdd2175285cb06ea8aa3702308713ea
diff --git a/lib/Role/Tiny.pm b/lib/Role/Tiny.pm
new file mode 100644
index 0000000..8d8d016
--- /dev/null
+++ b/lib/Role/Tiny.pm
@@ -0,0 +1,88 @@
+package Role::Tiny;
+
+use strictures 1;
+use Class::Method::Modifiers ();
+
+our %INFO;
+our %APPLIED_TO;
+
+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 {
+      push @{$INFO{$target}{modifiers}||=[]}, [ $type => @_ ];
+    };
+  }
+  *{(do { no strict 'refs'; \*{"${target}::requires"}})} = sub {
+    push @{$INFO{$target}{requires}||=[]}, @_;
+  };
+  # 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
+  # is used later)
+  @{$INFO{$target}{not_methods}={}}{
+    '', map { *$_{CODE}||() } grep !(ref eq 'SCALAR'), values %$stash
+  } = ();
+  # a role does itself
+  $APPLIED_TO{$target} = { $target => undef };
+}
+
+sub apply_role_to_package {
+  my ($class, $role, $to) = @_;
+  die "This is apply_role_to_package" if ref($to);
+  die "Not a Role::Tiny" unless my $info = $INFO{$role};
+  my $methods = $info->{methods} ||= do {
+    # grab role symbol table
+    my $stash = do { no strict 'refs'; \%{"${role}::"}};
+    my $not_methods = $info->{not_methods};
+    +{
+      # grab all code entries that aren't in the not_methods list
+      map {
+	my $code = *{$stash->{$_}}{CODE};
+	# rely on the '' key we added in import for "no code here"
+	exists $not_methods->{$code||''} ? () : ($_ => $code)
+      } grep !(ref($stash->{$_}) eq 'SCALAR'), keys %$stash
+    };
+  };
+  # grab target symbol table
+  my $stash = do { no strict 'refs'; \%{"${to}::"}};
+  # determine already extant methods of target
+  my %has_methods;
+  @has_methods{grep
+    +((ref($stash->{$_}) eq 'SCALAR') || (*{$stash->{$_}}{CODE})),
+    keys %$stash
+  } = ();
+  if (my @requires_fail
+	= grep !exists $has_methods{$_}, @{$info->{requires}||[]}) {
+    # role -> role, add to requires, role -> class, error out
+    if (my $to_info = $INFO{$to}) {
+      push @{$to_info->{requires}||=[]}, @requires_fail;
+    } else {
+      die "Can't apply ${role} to ${to} - missing ".join(', ', @requires_fail);
+    }
+  }
+
+  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};
+  }
+
+  foreach my $modifier (@{$info->{modifiers}||[]}) {
+    Class::Method::Modifiers::install_modifier($to, @{$modifier});
+  }
+
+  # copy our role list into the target's
+  @{$APPLIED_TO{$to}||={}}{keys %{$APPLIED_TO{$role}}} = ();
+}
+
+sub does_role {
+  my ($package, $role) = @_;
+  return exists $APPLIED_TO{$package}{$role};
+}
+
+1;
diff --git a/t/simple.t b/t/simple.t
new file mode 100644
index 0000000..ea5bb53
--- /dev/null
+++ b/t/simple.t
@@ -0,0 +1,48 @@
+use strictures 1;
+use Test::More qw(no_plan);
+use Test::Fatal;
+
+BEGIN {
+  package MyRole;
+
+  use Role::Tiny;
+
+  requires qw(req1 req2);
+
+  around foo => sub { my $orig = shift; join ' ', 'role foo', $orig->(@_) };
+
+  sub bar { 'role bar' }
+
+  sub baz { 'role baz' }
+}
+
+BEGIN {
+  package MyClass;
+
+  sub req1 { }
+  sub req2 { }
+  sub foo { 'class foo' }
+  sub baz { 'class baz' }
+
+}
+
+BEGIN {
+  package NoMethods;
+
+  package OneMethod;
+
+  sub req1 { }
+}
+
+sub try_apply_to {
+  my $to = shift;
+  exception { Role::Tiny->apply_role_to_package('MyRole', $to) }
+}
+
+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');
+
+like(try_apply_to('NoMethods'), qr/req1, req2/, 'error for both methods');
+like(try_apply_to('OneMethod'), qr/req2/, 'error for one method');