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 <dagol...@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 _______________________________________________ Pkg-perl-cvs-commits mailing list Pkg-perl-cvs-commits@lists.alioth.debian.org http://lists.alioth.debian.org/cgi-bin/mailman/listinfo/pkg-perl-cvs-commits