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 (file)
--- 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 (file)
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 (file)
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 (file)
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 (file)
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;