make ro accessor die

diff --git a/Changes b/Changes
index 77cfdc7..dcbee41 100644 (file)
--- a/Changes
+++ b/Changes
@@ -1,3 +1,4 @@
+  - perl based getter dies if @_ > 1 (XSAccessor already did)
   - add Role::Tiny::With for use in classes
   - automatically generate constructors in subclasses when required so that
     subclasses with a BUILD method but no attributes get it honoured

diff --git a/lib/Method/Generate/Accessor.pm b/lib/Method/Generate/Accessor.pm
index 078e884..c5398cf 100644 (file)
--- a/lib/Method/Generate/Accessor.pm
+++ b/lib/Method/Generate/Accessor.pm
@@ -7,6 +7,8 @@ use Sub::Quote;
 use B 'perlstring';
 BEGIN {
   our $CAN_HAZ_XS =
+    !$ENV{MOO_XS_DISABLE}
+      &&
     _maybe_load_module('Class::XSAccessor')
       &&
     (Class::XSAccessor->VERSION > 1.06)
@@ -38,7 +40,8 @@ sub generate_method {
       $self->{captures} = {};
       $methods{$reader} =
         quote_sub "${into}::${reader}"
-          => $self->_generate_get($name, $spec)
+          => '    die "'.$reader.' is a read-only accessor" if @_ > 1;'."\n"
+             .$self->_generate_get($name, $spec)
           => delete $self->{captures}
         ;
     }

diff --git a/t/accessor-reader-writer.t b/t/accessor-reader-writer.t
index da0ef89..68a0ae5 100644 (file)
--- a/t/accessor-reader-writer.t
+++ b/t/accessor-reader-writer.t
@@ -33,6 +33,8 @@ is( $foo->get_one, 'lol', 'reader works' );
 $foo->set_one('rofl');
 is( $foo->get_one, 'rofl', 'writer works' );
 
+ok( !eval { $foo->get_one('blah'); 1 }, 'reader dies on write' );
+
 is( $bar->TWO, '...', 'accessor works for reading' );
 $bar->TWO('!!!');
 is( $bar->TWO, '!!!', 'accessor works for writing' );

diff --git a/t/method-generate-accessor.t b/t/method-generate-accessor.t
index 6bd74e4..9c16b72 100644 (file)
--- a/t/method-generate-accessor.t
+++ b/t/method-generate-accessor.t
@@ -28,7 +28,7 @@ like(
 my $foo = Foo->new(one => 1);
 
 is($foo->one, 1, 'ro reads');
-$foo->one(-3) unless $Method::Generate::Accessor::CAN_HAZ_XS;
+ok(!eval { $foo->one(-3); 1 }, 'ro dies on write attempt');
 is($foo->one, 1, 'ro does not write');
 
 is($foo->two, undef, 'rw reads');