From 4c13c19ea541ef9daeb239a98ad63a592c5f5363 Mon Sep 17 00:00:00 2001
From: Chris Weyl <cweyl@alumni.drew.edu>
Date: Tue, 20 May 2014 01:26:57 -0700
Subject: [PATCH] initial _make_delegation_method() wrapping

...to allow us to generate custom accessors a la native traits:

    handles => {

        method_name => sub { ... accessor body (value in $_) ... }
    },

sooooooooooooooooo lazy.
---
 lib/MooseX/AttributeShortcuts.pm | 22 ++++++++++++++++++++++
 1 file changed, 22 insertions(+)

diff --git a/lib/MooseX/AttributeShortcuts.pm b/lib/MooseX/AttributeShortcuts.pm
index c9d537e..463ebc6 100644
--- a/lib/MooseX/AttributeShortcuts.pm
+++ b/lib/MooseX/AttributeShortcuts.pm
@@ -281,6 +281,28 @@ use Moose::Util::TypeConstraints;
             $class->add_method($self->builder => $self->anon_builder);
             return;
         };
+
+        # NOTE: remove_delegation() will automagically remove our accessors, as well
+
+        around _make_delegation_method => sub {
+            my ($orig, $self) = (shift, shift);
+            my ($name, $coderef) = @_;
+
+            ### called with a: ref $coderef
+            return $self->$orig(@_)
+                unless 'CODE' eq ref $coderef;
+
+            my $custom_coderef = sub {
+                my $associated_class_instance = shift @_;
+
+                local $_ = $self->get_value($associated_class_instance);
+                return $associated_class_instance->$coderef($self, @_);
+            };
+
+            return $self->_process_accessors(custom => { $name => $custom_coderef });
+        };
+
+        return;
     };
 }