From: gfx Date: Thu, 24 Sep 2009 07:14:27 +0000 (+0900) Subject: Add tests related to attribute traits X-Git-Tag: 0.35~33^2~2 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=85a83bedc70fd9308360199e2a57f768c9f67923;p=gitmo%2FMouse.git Add tests related to attribute traits --- diff --git a/t/000-recipes/moose_cookbook_meta_recipe3.t b/t/000-recipes/moose_cookbook_meta_recipe3.t new file mode 100644 index 0000000..fe1ab24 --- /dev/null +++ b/t/000-recipes/moose_cookbook_meta_recipe3.t @@ -0,0 +1,85 @@ +#!/usr/bin/perl -w + +use strict; +use Test::More 'no_plan'; +use Test::Exception; +$| = 1; + + + +# =begin testing SETUP +{ + + package MyApp::Meta::Attribute::Trait::Labeled; + use Mouse::Role; + + has label => ( + is => 'rw', + isa => 'Str', + predicate => 'has_label', + ); + + package Mouse::Meta::Attribute::Custom::Trait::Labeled; + sub register_implementation {'MyApp::Meta::Attribute::Trait::Labeled'} + + package MyApp::Website; + use Mouse; + + has url => ( + traits => [qw/Labeled/], + is => 'rw', + isa => 'Str', + label => "The site's URL", + ); + + has name => ( + is => 'rw', + isa => 'Str', + ); + + sub dump { + my $self = shift; + + my $dump = ''; + + my %attributes = %{ $self->meta->get_attribute_map }; + for my $name ( sort keys %attributes ) { + my $attribute = $attributes{$name}; + + if ( $attribute->does('MyApp::Meta::Attribute::Trait::Labeled') + && $attribute->has_label ) { + $dump .= $attribute->label; + } + else { + $dump .= $name; + } + + my $reader = $attribute->get_read_method; + $dump .= ": " . $self->$reader . "\n"; + } + + return $dump; + } + + package main; + + my $app = MyApp::Website->new( url => "http://google.com", name => "Google" ); +} + + + +# =begin testing +{ +my $app2 + = MyApp::Website->new( url => "http://google.com", name => "Google" ); +is( + $app2->dump, q{name: Google +The site's URL: http://google.com +}, '... got the expected dump value' +); +} + + + + +1; diff --git a/t/020_attributes/015_attribute_traits.t b/t/020_attributes/015_attribute_traits.t new file mode 100644 index 0000000..4197708 --- /dev/null +++ b/t/020_attributes/015_attribute_traits.t @@ -0,0 +1,72 @@ +#!/usr/bin/perl +use lib 't/lib'; + +use strict; +use warnings; + +use Test::More tests => 12; +use Test::Exception; +use Test::Mouse; + + + +{ + package My::Attribute::Trait; + use Mouse::Role; + + has 'alias_to' => (is => 'ro', isa => 'Str'); + + has foo => ( is => "ro", default => "blah" ); + + after 'install_accessors' => sub { + my $self = shift; + my $reader = $self->get_read_method; + + $self->associated_class->add_method( + $self->alias_to, + sub { shift->$reader(@_) }, + ); + }; +} + +{ + package My::Class; + use Mouse; + + has 'bar' => ( + traits => [qw/My::Attribute::Trait/], + is => 'ro', + isa => 'Int', + alias_to => 'baz', + ); + + has 'gorch' => ( + is => 'ro', + isa => 'Int', + default => sub { 10 } + ); +} + +my $c = My::Class->new(bar => 100); +isa_ok($c, 'My::Class'); + +is($c->bar, 100, '... got the right value for bar'); +is($c->gorch, 10, '... got the right value for gorch'); + +can_ok($c, 'baz'); +is($c->baz, 100, '... got the right value for baz'); + +my $bar_attr = $c->meta->get_attribute('bar'); + +does_ok($bar_attr, 'My::Attribute::Trait'); +ok($bar_attr->has_applied_traits, '... got the applied traits'); +is_deeply($bar_attr->applied_traits, [qw/My::Attribute::Trait/], '... got the applied traits'); +is($bar_attr->foo, "blah", "attr initialized"); + +my $gorch_attr = $c->meta->get_attribute('gorch'); +ok(!$gorch_attr->does('My::Attribute::Trait'), '... gorch doesnt do the trait'); +ok(!$gorch_attr->has_applied_traits, '... no traits applied'); +is($gorch_attr->applied_traits, undef, '... no traits applied'); + + +