From: stevan <stevan@3efe9002-19ed-0310-8735-a98156148065>
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();