From: Dave Rolsky Date: Thu, 20 Sep 2007 22:24:19 +0000 (+0000) Subject: The start of a working implementation. Several things left to be X-Git-Tag: 0.01~8 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=0f24a39d98269d89db1b902d5c763124ce5fc797;p=gitmo%2FMooseX-ClassAttribute.git The start of a working implementation. Several things left to be resolved ... How to set the default for a non-lazy class attribute, since it doesn't get set in a constructor? How to avoid having these attributes show up in the object hash. This requires messing with the inline & not-inline constructor. Make clearer and predicate options work with class attributes. More tests - reader, writer, predicate, clearer, coercion, lazy, etc. --- diff --git a/lib/MooseX/ClassAttribute.pm b/lib/MooseX/ClassAttribute.pm index 1b5a0c6..3b899c3 100644 --- a/lib/MooseX/ClassAttribute.pm +++ b/lib/MooseX/ClassAttribute.pm @@ -4,6 +4,28 @@ use warnings; use strict; our $VERSION = '0.01'; +our $AUTHORITY = 'cpan:DROLSKY'; + +use Moose; +use MooseX::ClassAttribute::Meta::Method::Accessor; + +extends 'Moose::Meta::Attribute'; + +sub accessor_metaclass { 'MooseX::ClassAttribute::Meta::Method::Accessor' } + +# This is called when an object is constructed. +sub initialize_instance_slot +{ + return; +} + + +# This is the bit of magic that lets you specify the metaclass as +# 'ClassAttribute', rather than the full name, when creating an +# attribute. +package Moose::Meta::Attribute::Custom::ClassAttribute; + +sub register_implementation { 'MooseX::ClassAttribute' } 1; @@ -16,7 +38,6 @@ __END__ MooseX::ClassAttribute - The fantastic new MooseX::ClassAttribute! - =head1 SYNOPSIS Quick summary of what the module does. @@ -25,7 +46,7 @@ Perhaps a little code snippet. use MooseX::ClassAttribute; - my $foo = MooseX::ClassAttribute->new; + my $foo = MooseX::ClassAttribute->new(); ... diff --git a/lib/MooseX/ClassAttribute/Meta/Method/Accessor.pm b/lib/MooseX/ClassAttribute/Meta/Method/Accessor.pm new file mode 100644 index 0000000..2f6b0a6 --- /dev/null +++ b/lib/MooseX/ClassAttribute/Meta/Method/Accessor.pm @@ -0,0 +1,58 @@ +package MooseX::ClassAttribute::Meta::Method::Accessor; + +use warnings; +use strict; + +our $VERSION = '0.01'; +our $AUTHORITY = 'cpan:DROLSKY'; + +use Moose; + +extends 'Moose::Meta::Method::Accessor'; + + +sub _inline_store { + my $self = shift; + my $instance = shift; + my $value = shift; + + my $attr = $self->associated_attribute(); + + my $mi = $attr->associated_class()->get_meta_instance(); + my $slot_name = $attr->slots(); + + my $package_var = sprintf q{$%s::__ClassAttribute{'%s'}}, $attr->associated_class()->name(), $slot_name; + + my $code = "$package_var = $value;"; + $code .= "Scalar::Util::weaken $package_var;" + if $attr->is_weak_ref(); + + return $code; +} + +sub _inline_get { + my $self = shift; + my $instance = shift; + + my $attr = $self->associated_attribute(); + + my $mi = $attr->associated_class()->get_meta_instance(); + my $slot_name = $attr->slots(); + + return sprintf q{$%s::__ClassAttribute{'%s'}}, $attr->associated_class()->name(), $slot_name; +} + +sub generate_accessor_method { + shift->generate_accessor_method_inline(@_); +} + +sub generate_reader_method { + shift->generate_reader_method_inline(@_); +} + +sub generate_writer_method { + shift->generate_writer_method_inline(@_); +} + + +1; diff --git a/t/01-basic.t b/t/01-basic.t new file mode 100644 index 0000000..ac68764 --- /dev/null +++ b/t/01-basic.t @@ -0,0 +1,8 @@ +use strict; +use warnings; + +use lib 't/lib'; + +use SharedTests; + +SharedTests::run_tests(); diff --git a/t/02-immutable.t b/t/02-immutable.t new file mode 100644 index 0000000..c91ce95 --- /dev/null +++ b/t/02-immutable.t @@ -0,0 +1,10 @@ +use strict; +use warnings; + +use lib 't/lib'; + +use SharedTests; + +HasClassAttribute->meta()->make_immutable(); + +SharedTests::run_tests(); diff --git a/t/lib/SharedTests.pm b/t/lib/SharedTests.pm new file mode 100644 index 0000000..3d9c242 --- /dev/null +++ b/t/lib/SharedTests.pm @@ -0,0 +1,86 @@ +package SharedTests; + +use strict; +use warnings; + +use Scalar::Util qw( isweak ); +use Test::More tests => 9; + + +{ + package HasClassAttribute; + + use Moose; + use MooseX::ClassAttribute; + + has 'ObjectCount' => + ( metaclass => 'ClassAttribute', + is => 'rw', + isa => 'Int', + default => 0, + ); + + has 'WeakAttribute' => + ( metaclass => 'ClassAttribute', + is => 'rw', + isa => 'Object', + weak_ref => 1, + ); + + has 'size' => + ( is => 'rw', + isa => 'Int', + default => 5, + ); + + sub BUILD + { + my $class = shift; + + $class->ObjectCount( $class->ObjectCount() + 1 ); + } +} + +sub run_tests +{ + local $Test::Builder::Level = $Test::Builder::Level + 1; + + { + 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' ); + } + + { + my $hca3 = HasClassAttribute->new( ObjectCount => 20 ); + is( $hca3->ObjectCount(), 3, + 'class attributes are not affected by constructor params' ); + is( HasClassAttribute->ObjectCount(), 3, + 'class attributes are not affected by constructor params' ); + } + + { + my $object = bless {}, 'Thing'; + + HasClassAttribute->WeakAttribute($object); + + ok( isweak( $HasClassAttribute::__ClassAttribute{WeakAttribute} ), + 'weak class attributes are weak' ); + } +} + + +1;