[libclass-tiny-perl] 10/22: allow custom accessors without 'redefined' warnings

[gregor herrmann]

This is an automated email from the git hooks/post-receive script.

gregoa pushed a commit to annotated tag release-0.001
in repository libclass-tiny-perl.

commit aeb05851b93e4146ea594119f19b856c6b600aa9
Author: David Golden <dagolden at cpan.org>
Date:   Fri Aug 16 06:54:21 2013 -0400

    allow custom accessors without 'redefined' warnings
---
 lib/Class/Tiny.pm | 21 +++++++++++++++++----
 t/charlie.t       | 26 ++++++++++++++++++++++++++
 t/lib/Charlie.pm  | 18 ++++++++++++++++++
 3 files changed, 61 insertions(+), 4 deletions(-)

diff --git a/lib/Class/Tiny.pm b/lib/Class/Tiny.pm
index 9b6dbcd..d0c7262 100644
--- a/lib/Class/Tiny.pm
+++ b/lib/Class/Tiny.pm
@@ -30,8 +30,8 @@ sub import {
         defined and !ref and /^[^\W\d]\w*$/s
           or Carp::croak "Invalid accessor name '$_'";
         "sub $_ { if (\@_ > 1) { \$_[0]->{$_} = \$_[1] } ; return \$_[0]->{$_} }\n"
-      } @attr;
-    Carp::croak( "Failed to generate $pkg" ) if $@;
+      } grep { !$pkg->can($_) } @attr;
+    Carp::croak("Failed to generate $pkg") if $@;
     return 1;
 }
 
@@ -102,7 +102,8 @@ code.  Here is a list of features:
 
 =for :list
 * defines attributes via import arguments
-* generates accessors for all attributes
+* generates read-write accessors for attributes
+* supports custom accessors
 * superclass provides a standard C<new> constructor
 * C<new> takes a hash reference or list of key/value pairs
 * C<new> throws an error for unknown attributes
@@ -139,13 +140,25 @@ Define attributes as a list of import arguments:
         weight
     );
 
-For each item, a read-write accessor is created:
+For each item, a read-write accessor is created unless a subroutine of that
+name already exists:
 
     $obj->name( "John Doe" );
 
 Attribute names must be valid subroutine identifiers or an exception will
 be thrown.
 
+To make your own custom accessors, just pre-declare the method name before
+loading Class::Tiny:
+
+    package Foo::Bar;
+
+    use subs 'id';
+
+    use Class::Tiny qw( name id );
+
+    sub id { ... }
+
 =head2 Subclassing
 
 Define subclasses as normal.  It's best to define them with L<base>, L<parent>
diff --git a/t/charlie.t b/t/charlie.t
new file mode 100644
index 0000000..7ba5754
--- /dev/null
+++ b/t/charlie.t
@@ -0,0 +1,26 @@
+use 5.008001;
+use strict;
+use warnings;
+use Test::More 0.96;
+use Test::FailWarnings;
+use Test::Deep '!blessed';
+use Test::Fatal;
+
+use lib 't/lib';
+
+require_ok("Charlie");
+
+subtest "all attributes set as list" => sub {
+    my $obj = new_ok( "Charlie", [ foo => 13, bar => [42] ] );
+    is( $obj->foo, 13, "foo is set" );
+    is_deeply( $obj->bar, [42], "bar is set" );
+};
+
+subtest "custom accessor" => sub {
+    my $obj = new_ok( "Charlie", [ foo => 13, bar => [42] ] );
+    is_deeply( $obj->bar( qw/1 1 2 3 5/ ), [ qw/1 1 2 3 5/ ], "bar is set" );
+};
+
+done_testing;
+# COPYRIGHT
+# vim: ts=4 sts=4 sw=4 et:
diff --git a/t/lib/Charlie.pm b/t/lib/Charlie.pm
new file mode 100644
index 0000000..9144eaa
--- /dev/null
+++ b/t/lib/Charlie.pm
@@ -0,0 +1,18 @@
+use 5.008001;
+use strict;
+use warnings;
+package Charlie;
+
+use subs qw/bar/;
+
+use Class::Tiny qw/foo bar/;
+
+sub bar {
+    my $self = shift;
+    if ( @_ ) {
+        $self->{bar} = [ @_ ];
+    }
+    return $self->{bar};
+}
+
+1;

-- 
Alioth's /usr/local/bin/git-commit-notice on /srv/git.debian.org/git/pkg-perl/packages/libclass-tiny-perl.git