X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=t%2Flib%2FSharedTests.pm;h=aa4a72cfd9effc0532ecb51aa6d8bde9237e6a81;hb=e6b328144a37b7adda944f989e1c1b4299a98e3f;hp=9df7a6e14aa30771bf8c81ec0e3c3889b4ba2282;hpb=5091e7b52c1532d96210b3fe0779c831b5e4eb30;p=gitmo%2FMooseX-ClassAttribute.git diff --git a/t/lib/SharedTests.pm b/t/lib/SharedTests.pm index 9df7a6e..aa4a72c 100644 --- a/t/lib/SharedTests.pm +++ b/t/lib/SharedTests.pm @@ -6,17 +6,79 @@ use warnings; use Scalar::Util qw( isweak ); use Test::More; -my $HasMXAH; -BEGIN -{ - if ( eval 'use MooseX::AttributeHelpers 0.09; 1;' ) - { - $HasMXAH = 1; - } -} - -plan tests => 25; - +use vars qw($Lazy); + +our %Attrs = ( + ObjectCount => { + is => 'rw', + isa => 'Int', + default => 0, + }, + WeakAttribute => { + is => 'rw', + isa => 'Object', + weak_ref => 1, + }, + LazyAttribute => { + is => 'rw', + isa => 'Int', + lazy => 1, + # The side effect is used to test that this was called + # lazily. + default => sub { $Lazy = 1 }, + }, + ReadOnlyAttribute => { + is => 'ro', + isa => 'Int', + default => 10, + }, + ManyNames => { + is => 'rw', + isa => 'Int', + reader => 'M', + writer => 'SetM', + clearer => 'ClearM', + predicate => 'HasM', + }, + Delegatee => { + is => 'rw', + isa => 'Delegatee', + handles => [ 'units', 'color' ], + # if it's not lazy it makes a new object before we define + # Delegatee's attributes. + lazy => 1, + default => sub { Delegatee->new() }, + }, + Mapping => { + traits => ['Hash'], + is => 'rw', + isa => 'HashRef[Str]', + default => sub { {} }, + handles => { + 'ExistsInMapping' => 'exists', + 'IdsInMapping' => 'keys', + 'GetMapping' => 'get', + 'SetMapping' => 'set', + }, + }, + Built => { + is => 'ro', + builder => '_BuildIt', + }, + LazyBuilt => { + is => 'ro', + lazy => 1, + builder => '_BuildIt', + }, + Triggerish => { + is => 'rw', + trigger => sub { shift->_CallTrigger(@_) }, + }, + TriggerRecord => { + is => 'ro', + default => sub { [] }, + }, +); { package HasClassAttribute; @@ -24,90 +86,34 @@ plan tests => 25; use Moose qw( has ); use MooseX::ClassAttribute; - use vars qw($Lazy); - $Lazy = 0; - - class_has 'ObjectCount' => - ( is => 'rw', - isa => 'Int', - default => 0, - ); - - class_has 'WeakAttribute' => - ( is => 'rw', - isa => 'Object', - weak_ref => 1, - ); - - class_has 'LazyAttribute' => - ( is => 'rw', - isa => 'Int', - lazy => 1, - # The side effect is used to test that this was called - # lazily. - default => sub { $Lazy = 1 }, - ); - - class_has 'ReadOnlyAttribute' => - ( is => 'ro', - isa => 'Int', - default => 10, - ); - - class_has 'ManyNames' => - ( is => 'rw', - isa => 'Int', - reader => 'M', - writer => 'SetM', - clearer => 'ClearM', - predicate => 'HasM', - ); - - class_has 'Delegatee' => - ( is => 'rw', - isa => 'Delegatee', - handles => [ 'units', 'color' ], - default => sub { Delegatee->new() }, - ); - - if ($HasMXAH) - { - class_has 'Mapping' => - ( metaclass => 'Collection::Hash', - is => 'rw', - isa => 'HashRef[Str]', - default => sub { {} }, - provides => - { exists => 'ExistsInMapping', - keys => 'IdsInMapping', - get => 'GetMapping', - set => 'SetMapping', - }, - ); + while ( my ( $name, $def ) = each %SharedTests::Attrs ) { + class_has $name => %{$def}; } - has 'size' => - ( is => 'rw', - isa => 'Int', - default => 5, - ); + has 'size' => ( + is => 'rw', + isa => 'Int', + default => 5, + ); no Moose; - no MooseX::ClassAttribute; - sub BUILD - { + sub BUILD { my $self = shift; $self->ObjectCount( $self->ObjectCount() + 1 ); } - sub make_immutable - { + sub _BuildIt {42} + + sub _CallTrigger { + push @{ $_[0]->TriggerRecord() }, [@_]; + } + + sub make_immutable { my $class = shift; $class->meta()->make_immutable(); - MooseX::ClassAttribute::container_class()->meta()->make_immutable(); Delegatee->meta()->make_immutable(); } } @@ -117,15 +123,17 @@ plan tests => 25; use Moose; - has 'units' => - ( is => 'ro', - default => 5, - ); + has 'units' => ( + is => 'ro', + default => 5, + ); - has 'color' => - ( is => 'ro', - default => 'blue', - ); + has 'color' => ( + is => 'ro', + default => 'blue', + ); + + no Moose; } { @@ -136,124 +144,206 @@ plan tests => 25; extends 'HasClassAttribute'; - class_has '+ReadOnlyAttribute' => - ( default => 30 ); + class_has '+ReadOnlyAttribute' => ( default => 30 ); + + class_has 'YetAnotherAttribute' => ( + is => 'ro', + default => 'thing', + ); + + no Moose; } -sub run_tests -{ +sub run_tests { + my $thing = shift || 'HasClassAttribute'; + local $Test::Builder::Level = $Test::Builder::Level + 1; + $Lazy = 0; + + my $count = ref $thing ? 1 : 0; + { - is( HasClassAttribute->ObjectCount(), 0, - 'ObjectCount() is 0' ); - - my $hca1 = HasClassAttribute->new(); - is( $hca1->size(), 5, - 'size is 5 - object attribute works as expected' ); - is( HasClassAttribute->ObjectCount(), 1, - 'ObjectCount() is 1' ); - - my $hca2 = HasClassAttribute->new( size => 10 ); - is( $hca2->size(), 10, - 'size is 10 - object attribute can be set via constructor' ); - is( HasClassAttribute->ObjectCount(), 2, - 'ObjectCount() is 2' ); - is( $hca2->ObjectCount(), 2, - 'ObjectCount() is 2 - can call class attribute accessor on object' ); + is( + $thing->ObjectCount(), $count, + 'ObjectCount() is 0' + ); + + unless ( ref $thing ) { + my $hca1 = $thing->new(); + is( + $hca1->size(), 5, + 'size is 5 - object attribute works as expected' + ); + is( + $thing->ObjectCount(), 1, + 'ObjectCount() is 1' + ); + + my $hca2 = $thing->new( size => 10 ); + is( + $hca2->size(), 10, + 'size is 10 - object attribute can be set via constructor' + ); + is( + $thing->ObjectCount(), 2, + 'ObjectCount() is 2' + ); + is( + $hca2->ObjectCount(), 2, + 'ObjectCount() is 2 - can call class attribute accessor on object' + ); + } } - { - my $hca3 = HasClassAttribute->new( ObjectCount => 20 ); - is( $hca3->ObjectCount(), 3, - 'class attributes passed to the constructor do not get set in the object' ); - is( HasClassAttribute->ObjectCount(), 3, - 'class attributes are not affected by constructor params' ); + unless ( ref $thing ) { + my $hca3 = $thing->new( ObjectCount => 20 ); + is( + $hca3->ObjectCount(), 3, + 'class attributes passed to the constructor do not get set in the object' + ); + is( + $thing->ObjectCount(), 3, + 'class attributes are not affected by constructor params' + ); } { my $object = bless {}, 'Thing'; - HasClassAttribute->WeakAttribute($object); + $thing->WeakAttribute($object); undef $object; - ok( ! defined HasClassAttribute->WeakAttribute(), - 'weak class attributes are weak' ); + ok( + !defined $thing->WeakAttribute(), + 'weak class attributes are weak' + ); } { - is( $HasClassAttribute::Lazy, 0, - '$HasClassAttribute::Lazy is 0' ); + is( + $SharedTests::Lazy, 0, + '$SharedTests::Lazy is 0' + ); - is( HasClassAttribute->LazyAttribute(), 1, - 'HasClassAttribute->LazyAttribute() is 1' ); + is( + $thing->LazyAttribute(), 1, + '$thing->LazyAttribute() is 1' + ); - is( $HasClassAttribute::Lazy, 1, - '$HasClassAttribute::Lazy is 1 after calling LazyAttribute' ); + is( + $SharedTests::Lazy, 1, + '$SharedTests::Lazy is 1 after calling LazyAttribute' + ); } { - eval { HasClassAttribute->ReadOnlyAttribute(20) }; - like( $@, qr/\QCannot assign a value to a read-only accessor/, - 'cannot set read-only class attribute' ); + eval { $thing->ReadOnlyAttribute(20) }; + like( + $@, qr/\QCannot assign a value to a read-only accessor/, + 'cannot set read-only class attribute' + ); } { - is( Child->ReadOnlyAttribute(), 30, - q{Child class can extend parent's class attribute} ); + is( + Child->ReadOnlyAttribute(), 30, + q{Child class can extend parent's class attribute} + ); } { - ok( ! HasClassAttribute->HasM(), - 'HasM() returns false before M is set' ); + ok( + !$thing->HasM(), + 'HasM() returns false before M is set' + ); - HasClassAttribute->SetM(22); + $thing->SetM(22); - ok( HasClassAttribute->HasM(), - 'HasM() returns true after M is set' ); - is( HasClassAttribute->M(), 22, - 'M() returns 22' ); + ok( + $thing->HasM(), + 'HasM() returns true after M is set' + ); + is( + $thing->M(), 22, + 'M() returns 22' + ); - HasClassAttribute->ClearM(); + $thing->ClearM(); - ok( ! HasClassAttribute->HasM(), - 'HasM() returns false after M is cleared' ); + ok( + !$thing->HasM(), + 'HasM() returns false after M is cleared' + ); } { - isa_ok( HasClassAttribute->Delegatee(), 'Delegatee', - 'has a Delegetee object' ); - is( HasClassAttribute->units(), 5, - 'units() delegates to Delegatee and returns 5' ); + isa_ok( + $thing->Delegatee(), 'Delegatee', + 'has a Delegetee object' + ); + is( + $thing->units(), 5, + 'units() delegates to Delegatee and returns 5' + ); } { - ok( ! HasClassAttribute->can('class_has'), - q{'no MooseX::ClassAttribute' remove class_has from HasClassAttribute} ); + my @ids = $thing->IdsInMapping(); + is( + scalar @ids, 0, + 'there are no keys in the mapping yet' + ); + + ok( + !$thing->ExistsInMapping('a'), + 'key does not exist in mapping' + ); + + $thing->SetMapping( a => 20 ); + + ok( + $thing->ExistsInMapping('a'), + 'key does exist in mapping' + ); + + is( + $thing->GetMapping('a'), 20, + 'value for a in mapping is 20' + ); } - SKIP: { - skip 'These tests require MooseX::AttributeHelpers', 4 - unless $HasMXAH; + is( + $thing->Built(), 42, + 'attribute with builder works' + ); - my @ids = HasClassAttribute->IdsInMapping(); - is( scalar @ids, 0, - 'there are no keys in the mapping yet' ); + is( + $thing->LazyBuilt(), 42, + 'attribute with lazy builder works' + ); + } - ok( ! HasClassAttribute->ExistsInMapping('a'), - 'key does not exist in mapping' ); + { + $thing->Triggerish(42); - HasClassAttribute->SetMapping( a => 20 ); + is( scalar @{ $thing->TriggerRecord() }, 1, 'trigger was called' ); + is( $thing->Triggerish(), 42, 'Triggerish is now 42' ); - ok( HasClassAttribute->ExistsInMapping('a'), - 'key does exist in mapping' ); + $thing->Triggerish(84); + is( $thing->Triggerish(), 84, 'Triggerish is now 84' ); - is( HasClassAttribute->GetMapping('a'), 20, - 'value for a in mapping is 20' ); + is_deeply( + $thing->TriggerRecord(), + [ + [ $thing, qw( 42 ) ], + [ $thing, qw( 84 42 ) ], + ], + 'trigger passes old value correctly' + ); } } - 1;