[libclass-tiny-perl] 07/22: validate accessors across superclasses

[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 2c2c1a9897fd31acdc30ebb54244484f2d158486
Author: David Golden <dagolden at cpan.org>
Date:   Thu Aug 15 22:21:02 2013 -0400

    validate accessors across superclasses
---
 lib/Class/Tiny.pm |  4 +++-
 t/baker.t         | 68 +++++++++++++++++++++++++++++++++++++++++++++++++++++++
 t/lib/Baker.pm    |  9 ++++++++
 3 files changed, 80 insertions(+), 1 deletion(-)

diff --git a/lib/Class/Tiny.pm b/lib/Class/Tiny.pm
index 8e9b32b..2963af9 100644
--- a/lib/Class/Tiny.pm
+++ b/lib/Class/Tiny.pm
@@ -51,8 +51,10 @@ sub new {
         Carp::croak("$class->new() got an odd number of elements");
     }
     my @bad;
+    my @search = @{ mro::get_linear_isa($class) };
     for my $k ( keys %$args ) {
-        push @bad, $k unless $CLASS_ATTRIBUTES{$class}{$k};
+        push @bad, $k
+          unless grep { $CLASS_ATTRIBUTES{$_}{$k} } @search;
     }
     if (@bad) {
         Carp::croak("Invalid attributes for $class: @bad");
diff --git a/t/baker.t b/t/baker.t
new file mode 100644
index 0000000..3860759
--- /dev/null
+++ b/t/baker.t
@@ -0,0 +1,68 @@
+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("Baker");
+
+subtest "empty list constructor" => sub {
+    my $obj = new_ok("Baker");
+    is( $obj->foo, undef, "foo is undef" );
+    is( $obj->bar, undef, "bar is undef" );
+    is( $obj->baz, undef, "baz is undef" );
+};
+
+subtest "empty hash object constructor" => sub {
+    my $obj = new_ok( "Baker", [ {} ] );
+    is( $obj->foo, undef, "foo is undef" );
+    is( $obj->bar, undef, "bar is undef" );
+    is( $obj->baz, undef, "baz is undef" );
+};
+
+subtest "subclass attribute set as list" => sub {
+    my $obj = new_ok( "Baker", [ baz => 23 ] );
+    is( $obj->foo, undef, "foo is undef" );
+    is( $obj->bar, undef, "bar is undef" );
+    is( $obj->baz, 23,    "baz is set " );
+};
+
+subtest "superclass attribute set as list" => sub {
+    my $obj = new_ok( "Baker", [ bar => 42, baz => 23 ] );
+    is( $obj->foo, undef, "foo is undef" );
+    is( $obj->bar, 42, "bar is set" );
+    is( $obj->baz, 23,    "baz is set " );
+};
+
+subtest "all attributes set as list" => sub {
+    my $obj = new_ok( "Baker", [ foo => 13, bar => 42, baz => 23 ] );
+    is( $obj->foo, 13, "foo is set" );
+    is( $obj->bar, 42, "bar is set" );
+    is( $obj->baz, 23,    "baz is set " );
+};
+
+subtest "attributes are RW" => sub {
+    my $obj = new_ok( "Baker", [ { foo => 23, bar => 42 } ] );
+    is( $obj->foo(24), 24, "changing foo returns new value" );
+    is( $obj->foo, 24, "accessing foo returns changed value" );
+    is( $obj->baz(42), 42, "changing baz returns new value" );
+    is( $obj->baz, 42, "accessing baz returns changed value" );
+};
+
+subtest "exceptions" => sub {
+    like(
+        exception { Baker->new( foo => 23, bar => 42, baz => 13, wibble => 0 ) },
+        qr/Invalid attributes for Baker: wibble/,
+        "creating object with 'wibble' dies",
+    );
+
+};
+
+
+done_testing;
+# COPYRIGHT
+# vim: ts=4 sts=4 sw=4 et:
diff --git a/t/lib/Baker.pm b/t/lib/Baker.pm
new file mode 100644
index 0000000..0274321
--- /dev/null
+++ b/t/lib/Baker.pm
@@ -0,0 +1,9 @@
+use 5.008001;
+use strict;
+use warnings;
+package Baker;
+use base 'Alfa';
+
+use Class::Tiny qw/baz/;
+
+1;

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