From: Matt S Trout <matthewt@hercule.scsys.co.uk>
Date: Fri, 12 Nov 2010 07:32:13 +0000 (+0000)
Subject: handles and asserter support
X-Git-Tag: 0.009001~33
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=4db3a7403e42fab35d8814fca3ad4192547bb997;p=gitmo%2FMoo.git

handles and asserter support
---

diff --git a/lib/Method/Generate/Accessor.pm b/lib/Method/Generate/Accessor.pm
index e57a397..f6093eb 100644
--- a/lib/Method/Generate/Accessor.pm
+++ b/lib/Method/Generate/Accessor.pm
@@ -90,6 +90,38 @@ sub generate_method {
         "    delete \$_[0]->{${\perlstring $name}}\n"
       ;
   }
+  if (my $hspec = $spec->{handles}) {
+    my $asserter = $spec->{asserter} ||= '_assert_'.$name;
+    my @specs = do {
+      if (ref($hspec) eq 'ARRAY') {
+        map [ $_ => $_ ], @$hspec;
+      } elsif (ref($hspec) eq 'HASH') {
+        map [ $_ => ref($hspec->{$_}) ? @{$hspec->{$_}} : $hspec->{$_} ],
+          keys %$hspec;
+      } elsif (!ref($hspec)) {
+        map [ $_ => $_ ], Role::Tiny->methods_provided_by($hspec);
+      } else {
+        die "You gave me a handles of ${hspec} and I have no idea why";
+      }
+    };
+    foreach my $spec (@specs) {
+      my ($proxy, $target, @args) = @$spec;
+      local $self->{captures} = {};
+      $methods{$proxy} =
+        quote_sub "${into}::${proxy}" =>
+          $self->_generate_delegation($asserter, $target, \@args),
+          $self->{captures}
+        ;
+    }
+  }
+  if (my $asserter = $spec->{asserter}) {
+    local $self->{captures} = {};
+    $methods{$asserter} =
+      quote_sub "${into}::${asserter}" =>
+        'do { '.$self->_generate_get($name, $spec).qq! }||die "Attempted to access '${name}' but it is not set"!,
+        $self->{captures}
+      ;
+  }
   \%methods;
 }
 
@@ -311,6 +343,21 @@ sub _generate_getset {
     ."\n      : ".$self->_generate_get($name)."\n    )";
 }
 
+sub _generate_delegation {
+  my ($self, $asserter, $target, $args) = @_;
+  my $arg_string = do {
+    if (@$args) {
+      # I could, I reckon, linearise out non-refs here using perlstring
+      # plus something to check for numbers but I'm unsure if it's worth it
+      $self->{captures}{'@curries'} = $args;
+      '@curries, @_';
+    } else {
+      '@_';
+    }
+  };
+  "shift->${asserter}->${target}(${arg_string});";
+}
+
 sub _generate_xs {
   my ($self, $type, $into, $name, $slot) = @_;
   Class::XSAccessor->import(
diff --git a/lib/Role/Tiny.pm b/lib/Role/Tiny.pm
index 74f83f6..ee75997 100644
--- a/lib/Role/Tiny.pm
+++ b/lib/Role/Tiny.pm
@@ -139,12 +139,10 @@ sub _check_requires {
   }
 }
 
-sub _install_methods {
-  my ($me, $to, $role) = @_;
-
+sub _concrete_methods_of {
+  my ($me, $role) = @_;
   my $info = $INFO{$role};
-
-  my $methods = $info->{methods} ||= do {
+  $info->{methods} ||= do {
     # grab role symbol table
     my $stash = do { no strict 'refs'; \%{"${role}::"}};
     my $not_methods = $info->{not_methods};
@@ -157,6 +155,20 @@ sub _install_methods {
       } grep !(ref($stash->{$_}) eq 'SCALAR'), keys %$stash
     };
   };
+}
+
+sub methods_provided_by {
+  my ($me, $role) = @_;
+  die "${role} is not a Role::Tiny" unless my $info = $INFO{$role};
+  (keys %{$me->_concrete_methods_of($role)}, @{$info->{requires}||[]});
+}
+
+sub _install_methods {
+  my ($me, $to, $role) = @_;
+
+  my $info = $INFO{$role};
+
+  my $methods = $me->_concrete_methods_of($role);
 
   # grab target symbol table
   my $stash = do { no strict 'refs'; \%{"${to}::"}};