From: stevan Date: Wed, 9 Aug 2006 00:25:48 +0000 (+0000) Subject: adding in some basic policies and some tests X-Git-Tag: 0_01~2 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=461dc6d309a34d7c7ba4069f8dc79bbc0321cba7;p=gitmo%2FMoose-Policy.git adding in some basic policies and some tests --- diff --git a/lib/Moose/Policy.pm b/lib/Moose/Policy.pm index 32ee1ee..b609acc 100644 --- a/lib/Moose/Policy.pm +++ b/lib/Moose/Policy.pm @@ -1,7 +1,5 @@ package Moose::Policy; -# vim:ts=4:sw=4:et:sta - use strict; use warnings; diff --git a/lib/Moose/Policy/FollowPBP.pm b/lib/Moose/Policy/FollowPBP.pm new file mode 100644 index 0000000..0ba906b --- /dev/null +++ b/lib/Moose/Policy/FollowPBP.pm @@ -0,0 +1,36 @@ + +package Moose::Policy::FollowPBP; + +use constant attribute_metaclass => 'Moose::Policy::FollowPBP::Attribute'; + +package Moose::Policy::FollowPBP::Attribute; +use Moose; + +extends 'Moose::Meta::Attribute'; + +before '_process_options' => sub { + my ($class, $name, $options) = @_; + # NOTE: + # If is has been specified, and + # we don't have a reader or writer + # Of couse this is an odd case, but + # we better test for it anyway. + if (exists $options->{is} && !(exists $options->{reader} || exists $options->{writer})) { + if ($options->{is} eq 'ro') { + $options->{reader} = 'get_' . $name; + } + elsif ($options->{is} eq 'rw') { + $options->{reader} = 'get_' . $name; + $options->{writer} = 'set_' . $name; + } + delete $options->{is}; + } +}; + +1; + +__END__ + +=pod + +=cut diff --git a/lib/Moose/Policy/SingleInheritence.pm b/lib/Moose/Policy/SingleInheritence.pm new file mode 100644 index 0000000..27c4d37 --- /dev/null +++ b/lib/Moose/Policy/SingleInheritence.pm @@ -0,0 +1,24 @@ + +package Moose::Policy::SingleInheritence; + +use constant metaclass => 'Moose::Policy::SingleInheritence::MetaClass'; + +package Moose::Policy::SingleInheritence::MetaClass; +use Moose; + +extends 'Moose::Meta::Class'; + +before 'superclasses' => sub { + my ($self, @superclasses) = @_; + confess 'Moose::Policy::SingleInheritence in effect for ' . + $self->name . ', only single inheritence is allowed' + if scalar @superclasses > 1; +}; + +1; + +__END__ + +=pod + +=cut diff --git a/t/010_FollowPBP_test.t b/t/010_FollowPBP_test.t new file mode 100644 index 0000000..0416ead --- /dev/null +++ b/t/010_FollowPBP_test.t @@ -0,0 +1,38 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More 'no_plan'; + +BEGIN { + use_ok('Moose::Policy'); +} + +{ + package Foo; + + use Moose::Policy 'Moose::Policy::FollowPBP'; + use Moose; + + has 'bar' => (is => 'rw', default => 'Foo::bar'); + has 'baz' => (is => 'ro', default => 'Foo::baz'); +} + +isa_ok(Foo->meta, 'Moose::Meta::Class'); +is(Foo->meta->attribute_metaclass, 'Moose::Policy::FollowPBP::Attribute', '... got our custom attr metaclass'); + +isa_ok(Foo->meta->get_attribute('bar'), 'Moose::Policy::FollowPBP::Attribute'); + +my $foo = Foo->new; +isa_ok($foo, 'Foo'); + +can_ok($foo, 'get_bar'); +can_ok($foo, 'set_bar'); + +can_ok($foo, 'get_baz'); +ok(! $foo->can('set_baz'), 'without setter'); + +is($foo->get_bar, 'Foo::bar', '... got the right default value'); +is($foo->get_baz, 'Foo::baz', '... got the right default value'); + diff --git a/t/020_SingleInheritence_test.t b/t/020_SingleInheritence_test.t new file mode 100644 index 0000000..a9d208a --- /dev/null +++ b/t/020_SingleInheritence_test.t @@ -0,0 +1,32 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More 'no_plan'; +use Test::Exception; + +BEGIN { + use_ok('Moose::Policy'); +} + +{ + package Foo; + use Moose::Policy 'Moose::Policy::SingleInheritence'; + use Moose; + + package Bar; + use Moose::Policy 'Moose::Policy::SingleInheritence'; + use Moose; + + extends 'Foo'; + + package Baz; + use Moose::Policy 'Moose::Policy::SingleInheritence'; + use Moose; + + ::dies_ok { + extends 'Foo', 'Bar'; + } '... violating the policy'; +} + diff --git a/t/pod.t b/t/pod.t new file mode 100644 index 0000000..4ae1af3 --- /dev/null +++ b/t/pod.t @@ -0,0 +1,11 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More; + +eval "use Test::Pod 1.14"; +plan skip_all => "Test::Pod 1.14 required for testing POD" if $@; + +all_pod_files_ok(); diff --git a/t/pod_coverage.t b/t/pod_coverage.t new file mode 100644 index 0000000..7569358 --- /dev/null +++ b/t/pod_coverage.t @@ -0,0 +1,11 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More; + +eval "use Test::Pod::Coverage 1.04"; +plan skip_all => "Test::Pod::Coverage 1.04 required for testing POD coverage" if $@; + +all_pod_coverage_ok();