From: Matt S Trout <mst@shadowcat.co.uk>
Date: Wed, 2 May 2012 20:10:38 +0000 (+0000)
Subject: factor out accessor generation code a bit
X-Git-Tag: v0.091002~20
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=02e9ef74cf0e746aad5bed3684661622017dad87;p=gitmo%2FMoo.git

factor out accessor generation code a bit
---

diff --git a/Changes b/Changes
index 89b4f59..ef33b2e 100644
--- a/Changes
+++ b/Changes
@@ -1,3 +1,5 @@
+  - factor out accessor generation code a bit more to enable extension
+
 0.091001 - 2012-05-02
   - bump Role::Tiny dependency to require de-strictures-ed version
   - fix test failure where Class::XSAccessor is not available
diff --git a/lib/Method/Generate/Accessor.pm b/lib/Method/Generate/Accessor.pm
index ea5a4ed..9d15768 100644
--- a/lib/Method/Generate/Accessor.pm
+++ b/lib/Method/Generate/Accessor.pm
@@ -102,7 +102,7 @@ sub generate_method {
   if (my $cl = $spec->{clearer}) {
     $methods{$cl} =
       quote_sub "${into}::${cl}" => 
-        "    delete \$_[0]->{${\perlstring $name}}\n"
+        $self->_generate_simple_clear('$_[0]', $name)."\n"
       ;
   }
   if (my $hspec = $spec->{handles}) {
@@ -181,6 +181,11 @@ sub _generate_simple_has {
   "exists ${me}->{${\perlstring $name}}";
 }
 
+sub _generate_simple_clear {
+  my ($self, $me, $name) = @_;
+  "    delete ${me}->{${\perlstring $name}}\n"
+}
+
 sub generate_get_default {
   my $self = shift;
   $self->{captures} = {};
@@ -451,4 +456,6 @@ sub _generate_xs {
   $into->can($name);
 }
 
+sub default_construction_string { '{}' }
+
 1;
diff --git a/lib/Method/Generate/Constructor.pm b/lib/Method/Generate/Constructor.pm
index 86c5afb..d24a457 100644
--- a/lib/Method/Generate/Constructor.pm
+++ b/lib/Method/Generate/Constructor.pm
@@ -7,8 +7,13 @@ use Sub::Defer;
 use B 'perlstring';
 
 sub register_attribute_specs {
-  my ($self, %spec) = @_;
-  @{$self->{attribute_specs}||={}}{keys %spec} = values %spec;
+  my ($self, @new_specs) = @_;
+  my $specs = $self->{attribute_specs}||={};
+  while (my ($name, $new_spec) = splice @new_specs, 0, 2) {
+    $new_spec->{index} = scalar keys %$specs
+      unless exists $new_spec->{index};
+    $specs->{$name} = $new_spec;
+  }
   $self;
 }
 
@@ -22,7 +27,10 @@ sub accessor_generator {
 
 sub construction_string {
   my ($self) = @_;
-  $self->{construction_string} or 'bless({}, $class);'
+  $self->{construction_string}
+    or 'bless('
+       .$self->accessor_generator->default_construction_string
+       .', $class);'
 }
 
 sub install_delayed {
diff --git a/lib/Moo.pm b/lib/Moo.pm
index 1875989..6d402ae 100644
--- a/lib/Moo.pm
+++ b/lib/Moo.pm
@@ -33,12 +33,10 @@ sub import {
   $MAKERS{$target} = {};
   _install_coderef "${target}::has" => sub {
     my ($name, %spec) = @_;
-    ($MAKERS{$target}{accessor} ||= do {
-      require Method::Generate::Accessor;
-      Method::Generate::Accessor->new
-    })->generate_method($target, $name, \%spec);
     $class->_constructor_maker_for($target)
           ->register_attribute_specs($name, \%spec);
+    $class->_accessor_maker_for($target)
+          ->generate_method($target, $name, \%spec);
   };
   foreach my $type (qw(before after around)) {
     _install_coderef "${target}::${type}" => sub {
@@ -57,6 +55,31 @@ sub import {
   }
 }
 
+sub _accessor_maker_for {
+  my ($class, $target) = @_;
+  return unless $MAKERS{$target};
+  $MAKERS{$target}{accessor} ||= do {
+    my $maker_class = do {
+      if (my $m = do {
+            if (my $defer_target = 
+                  (Sub::Defer::defer_info($target->can('new'))||[])->[0]
+              ) {
+              my ($pkg) = ($defer_target =~ /^(.*)::[^:]+$/);
+              $MAKERS{$pkg} && $MAKERS{$pkg}{accessor};
+            } else {
+              undef;
+            }
+          }) {
+        ref($m);
+      } else {
+        require Method::Generate::Accessor;
+        'Method::Generate::Accessor'
+      }
+    };
+    $maker_class->new;
+  }
+}
+
 sub _constructor_maker_for {
   my ($class, $target, $select_super) = @_;
   return unless $MAKERS{$target};
@@ -84,13 +107,10 @@ sub _constructor_maker_for {
         $moo_constructor = 1; # no other constructor, make a Moo one
       }
     };
-    Method::Generate::Constructor
+    ($con ? ref($con) : 'Method::Generate::Constructor')
       ->new(
         package => $target,
-        accessor_generator => do {
-          require Method::Generate::Accessor;
-          Method::Generate::Accessor->new;
-        },
+        accessor_generator => $class->_accessor_maker_for($target),
         construction_string => (
           $moo_constructor
             ? ($con ? $con->construction_string : undef)