git diff master delegation-overwriting-rt81181

nopaste

diff --git a/Changes b/Changes
index 09d39ba..f9a8b4c 100644
--- a/Changes
+++ b/Changes
@@ -1,3 +1,5 @@
+  - has will refuse to overwrite locally defined subs with generated
+    accessors.
   - expand is => 'lazy' doc to make it clear that you can make rw lazy
     attributes if you really want to
   - handles => "RoleName" tries to load the module
diff --git a/lib/Method/Generate/Accessor.pm b/lib/Method/Generate/Accessor.pm
index 1a13a56..2fce625 100644
--- a/lib/Method/Generate/Accessor.pm
+++ b/lib/Method/Generate/Accessor.pm
@@ -18,9 +18,15 @@ BEGIN {
   ;
 }
 
+sub _die_overwrite
+{
+  my ($pkg, $method, $type) = @_;
+  die "You cannot overwrite a locally defined method ($method) with @{[ $type || 'an accessor' ]}";
+}
+
 sub generate_method {
   my ($self, $into, $name, $spec, $quote_opts) = @_;
-  $name =~ s/^\+//;
+  $spec->{allow_overwrite}++ if $name =~ s/^\+//;
   die "Must have an is" unless my $is = $spec->{is};
   if ($is eq 'ro') {
     $spec->{reader} = $name unless exists $spec->{reader};
@@ -73,6 +79,8 @@ sub generate_method {
 
   my %methods;
   if (my $reader = $spec->{reader}) {
+    _die_overwrite($into, $reader, 'a reader')
+      if !$spec->{allow_overwrite} && *{_getglob("${into}::${reader}")}{CODE};
     if (our $CAN_HAZ_XS && $self->is_simple_get($name, $spec)) {
       $methods{$reader} = $self->_generate_xs(
         getters => $into, $reader, $name, $spec
@@ -88,6 +96,8 @@ sub generate_method {
     }
   }
   if (my $accessor = $spec->{accessor}) {
+    _die_overwrite($into, $accessor, 'an accessor')
+      if !$spec->{allow_overwrite} && *{_getglob("${into}::${accessor}")}{CODE};
     if (
       our $CAN_HAZ_XS
       && $self->is_simple_get($name, $spec)
@@ -106,6 +116,8 @@ sub generate_method {
     }
   }
   if (my $writer = $spec->{writer}) {
+    _die_overwrite($into, $writer, 'a writer')
+      if !$spec->{allow_overwrite} && *{_getglob("${into}::${writer}")}{CODE};
     if (
       our $CAN_HAZ_XS
       && $self->is_simple_set($name, $spec)
@@ -123,6 +135,8 @@ sub generate_method {
     }
   }
   if (my $pred = $spec->{predicate}) {
+    _die_overwrite($into, $pred, 'a predicate')
+      if !$spec->{allow_overwrite} && *{_getglob("${into}::${pred}")}{CODE};
     $methods{$pred} =
       quote_sub "${into}::${pred}" =>
         '    '.$self->_generate_simple_has('$_[0]', $name, $spec)."\n"
@@ -132,6 +146,8 @@ sub generate_method {
     _install_coderef( "${into}::$spec->{builder}" => $spec->{builder_sub} );
   }
   if (my $cl = $spec->{clearer}) {
+    _die_overwrite($into, $cl, 'a clearer')
+      if !$spec->{allow_overwrite} && *{_getglob("${into}::${cl}")}{CODE};
     $methods{$cl} =
       quote_sub "${into}::${cl}" => 
         $self->_generate_simple_clear('$_[0]', $name, $spec)."\n"
@@ -151,8 +167,10 @@ sub generate_method {
         die "You gave me a handles of ${hspec} and I have no idea why";
       }
     };
-    foreach my $spec (@specs) {
-      my ($proxy, $target, @args) = @$spec;
+    foreach my $delegation_spec (@specs) {
+      my ($proxy, $target, @args) = @$delegation_spec;
+      _die_overwrite($into, $proxy, 'a delegation')
+        if !$spec->{allow_overwrite} && *{_getglob("${into}::${proxy}")}{CODE};
       $self->{captures} = {};
       $methods{$proxy} =
         quote_sub "${into}::${proxy}" =>
diff --git a/t/accessor-handles.t b/t/accessor-handles.t
index a0df36c..8063cca 100644
--- a/t/accessor-handles.t
+++ b/t/accessor-handles.t
@@ -62,4 +62,16 @@ is $bar->beep, 'beep', 'handles loads roles';
 
 is $bar->eat_curry, 'Curry!', 'handles works for currying';
 
+{
+	local $@;
+	ok !eval q{
+		package Baz;
+		use Moo;
+		has foo => ( is => 'ro', handles => 'Robot' );
+		sub smash { 1 };
+		1;
+	}, 'handles will not overwrite locally defined method';
+	like $@, qr{You cannot overwrite a locally defined method \(smash\) with a delegation};
+}
+
 done_testing;
diff --git a/t/accessor-roles.t b/t/accessor-roles.t
index eb8b8b6..d2ab470 100644
--- a/t/accessor-roles.t
+++ b/t/accessor-roles.t
@@ -1,5 +1,6 @@
 use strictures 1;
 use Test::More;
+use Test::Fatal;
 use Sub::Quote;
 
 {
@@ -22,4 +23,20 @@ is $c->one, "one",     "attr default set from class";
 is $c->two, "two",     "attr default set from role";
 is $c->three, "three", "attr default set from role";
 
+{
+	package Deux; use Moo; with 'One::P1';
+	::like(
+		::exception { has two => (is => 'ro', default => sub { 'II' }); },
+		qr{^You cannot overwrite a locally defined method \(two\) with a reader},
+		'overwriting accesssors with roles fails'
+	);
+}
+
+{
+	package Two; use Moo; with 'One::P1';
+	has '+two' => (is => 'ro', default => sub { 'II' });
+}
+
+is(Two->new->two, 'II', "overwriting accessors using +attr works");
+
 done_testing;
diff --git a/t/method-generate-accessor.t b/t/method-generate-accessor.t
index 64dbfee..f228729 100644
--- a/t/method-generate-accessor.t
+++ b/t/method-generate-accessor.t
@@ -34,37 +34,37 @@ like(
 
 for my $setting (qw( default coerce )) {
   like(
-    exception { $gen->generate_method('Foo' => 'four' => { is => 'ro', $setting => 5 }) },
+    exception { $gen->generate_method('Foo' => 'four' => { allow_overwrite => 1, is => 'ro', $setting => 5 }) },
     qr/Invalid $setting/, "$setting - scalar rejected"
   );
 
   like(
-    exception { $gen->generate_method('Foo' => 'five' => { is => 'ro', $setting => [] }) },
+    exception { $gen->generate_method('Foo' => 'five' => { allow_overwrite => 1, is => 'ro', $setting => [] }) },
     qr/Invalid $setting/, "$setting - arrayref rejected"
   );
 
   like(
-    exception { $gen->generate_method('Foo' => 'five' => { is => 'ro', $setting => Foo->new }) },
+    exception { $gen->generate_method('Foo' => 'five' => { allow_overwrite => 1, is => 'ro', $setting => Foo->new }) },
     qr/Invalid $setting/, "$setting - non-code-convertible object rejected"
   );
 
   is(
-    exception { $gen->generate_method('Foo' => 'six' => { is => 'ro', $setting => sub { 5 } }) },
+    exception { $gen->generate_method('Foo' => 'six' => { allow_overwrite => 1, is => 'ro', $setting => sub { 5 } }) },
     undef, "$setting - coderef accepted"
   );
 
   is(
-    exception { $gen->generate_method('Foo' => 'seven' => { is => 'ro', $setting => bless sub { 5 } => 'Blah' }) },
+    exception { $gen->generate_method('Foo' => 'seven' => { allow_overwrite => 1, is => 'ro', $setting => bless sub { 5 } => 'Blah' }) },
     undef, "$setting - blessed sub accepted"
   );
 
   is(
-    exception { $gen->generate_method('Foo' => 'eight' => { is => 'ro', $setting => WithOverload->new }) },
+    exception { $gen->generate_method('Foo' => 'eight' => { allow_overwrite => 1, is => 'ro', $setting => WithOverload->new }) },
     undef, "$setting - object with overloaded ->() accepted"
   );
 
   like(
-    exception { $gen->generate_method('Foo' => 'nine' => { is => 'ro', $setting => bless {} => 'Blah' }) },
+    exception { $gen->generate_method('Foo' => 'nine' => { allow_overwrite => 1, is => 'ro', $setting => bless {} => 'Blah' }) },
     qr/Invalid $setting/, "$setting - object rejected"
   );
 }
diff --git a/t/moo-accessors.t b/t/moo-accessors.t
index 5bb6b49..ef2cd64 100644
--- a/t/moo-accessors.t
+++ b/t/moo-accessors.t
@@ -51,4 +51,4 @@ is_deeply(
 ok(eval { Foo->meta->make_immutable }, 'make_immutable returns true');
 ok(!$INC{"Moose.pm"}, "Didn't load Moose");
 
-done_testing unless caller;
+done_testing;