From: Matt S Trout <mst@shadowcat.co.uk>
Date: Sun, 7 Nov 2010 02:21:15 +0000 (+0000)
Subject: ro and rw accessor generation
X-Git-Tag: 0.009001~72
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=51a3b1066c68a87d71222bd4487166c523e1cbc8;p=gitmo%2FRole-Tiny.git

ro and rw accessor generation
---

diff --git a/lib/Method/Generate/Accessor.pm b/lib/Method/Generate/Accessor.pm
new file mode 100644
index 0000000..6c6d30b
--- /dev/null
+++ b/lib/Method/Generate/Accessor.pm
@@ -0,0 +1,41 @@
+package Method::Generate::Accessor;
+
+use strictures 1;
+use Class::Tiny::_Utils;
+use base qw(Class::Tiny::Object);
+use Sub::Quote;
+use B 'perlstring';
+
+sub generate_methods {
+  my ($self, $into, $name, $spec) = @_;
+  die "Must have an is" unless my $is = $spec->{is};
+  my $name_str = perlstring $name;
+  my $body = do {
+    if ($is eq 'ro') {
+      '    '.$self->_generate_get($name_str)
+    } elsif ($is eq 'rw') {
+      '    '.$self->_generate_getset($name_str)
+    } else {
+      die "Unknown is ${is}";
+    }
+  };
+  quote_sub "${into}::${name}" => $body;
+}
+
+sub _generate_get {
+  my ($self, $name_str) = @_;
+  "\$_[0]->{${name_str}}";
+}
+
+sub _generate_set {
+  my ($self, $name_str, $value) = @_;
+  "\$_[0]->{${name_str}} = ${value}";
+}
+
+sub _generate_getset {
+  my ($self, $name_str) = @_;
+  q{(@_ > 1 ? }.$self->_generate_set($name_str, q{$_[1]})
+    .' : '.$self->_generate_get($name_str).')';
+}
+
+1;
diff --git a/t/method-generate-accessor.t b/t/method-generate-accessor.t
new file mode 100644
index 0000000..3845956
--- /dev/null
+++ b/t/method-generate-accessor.t
@@ -0,0 +1,38 @@
+use strictures 1;
+use Test::More;
+use Test::Fatal;
+
+use Method::Generate::Accessor;
+
+my $gen = Method::Generate::Accessor->new;
+
+{
+  package Foo;
+  use Class::Tiny;
+}
+
+$gen->generate_methods('Foo' => 'one' => { is => 'ro' });
+
+$gen->generate_methods('Foo' => 'two' => { is => 'rw' });
+
+like(
+  exception { $gen->generate_methods('Foo' => 'three' => {}) },
+  qr/Must have an is/, 'No is rejected'
+);
+
+like(
+  exception { $gen->generate_methods('Foo' => 'three' => { is => 'purple' }) },
+  qr/Unknown is purple/, 'is purple rejected'
+);
+
+my $foo = Foo->new(one => 1);
+
+is($foo->one, 1, 'ro reads');
+$foo->one(-3);
+is($foo->one, 1, 'ro does not write');
+
+is($foo->two, undef, 'rw reads');
+$foo->two(-3);
+is($foo->two, -3, 'rw writes');
+
+done_testing;