From: Dave Rolsky Date: Sat, 24 Nov 2007 21:34:38 +0000 (+0000) Subject: A working version, with docs and all tests passing. X-Git-Tag: 0.01~4 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?p=gitmo%2FMooseX-ClassAttribute.git;a=commitdiff_plain;h=54a288bd079674e4bc71a23449828f0be7691a43 A working version, with docs and all tests passing. --- diff --git a/lib/MooseX/ClassAttribute.pm b/lib/MooseX/ClassAttribute.pm index 66087b4..cdf664d 100644 --- a/lib/MooseX/ClassAttribute.pm +++ b/lib/MooseX/ClassAttribute.pm @@ -1,41 +1,117 @@ package MooseX::ClassAttribute; -use warnings; use strict; +use warnings; our $VERSION = '0.01'; our $AUTHORITY = 'cpan:DROLSKY'; -use Moose; -use MooseX::ClassAttribute::Meta::Method::Accessor; - -extends 'Moose::Meta::Attribute'; +our @EXPORT = 'class_has'; ## no critic ProhibitAutomaticExportation +use Exporter qw( import ); +use B qw( svref_2object ); +use Sub::Name; -sub accessor_metaclass { 'MooseX::ClassAttribute::Meta::Method::Accessor' } -# This is called when an object is constructed. -sub initialize_instance_slot +sub class_has ## no critic RequireArgUnpacking { - my ( $self, $meta_instance, $instance, $params ) = @_; + my $caller = caller(); + + my $caller_meta = $caller->meta(); + + my @parents = $caller_meta->superclasses(); + + my $container_pkg = _make_container_class( $caller, @parents ); - return unless $self->has_init_arg(); + my $has = $container_pkg->can('has'); + $has->(@_); - my $init_arg = $self->init_arg(); + my $container_meta = $container_pkg->meta(); + for my $meth ( grep { $_ ne 'instance' } $container_meta->get_method_list() ) + { + next if $caller_meta->has_method($meth); - confess "Cannot set a class attribute via the constructor ($init_arg)" - if exists $params->{$init_arg}; + my $sub = sub { shift; + my $instance = $container_pkg->instance(); + return $instance->$meth(@_); }; + + $caller_meta->add_method( $meth => $sub ); + } return; } +{ + # This should probably be an attribute of the metaclass, but that + # would require extending Moose::Meta::Class, which would conflict + # with anything else that wanted to do so as well (we need + # metaclass roles or something). + my %Name; + + sub _make_container_class ## no critic RequireArgUnpacking + { + my $caller = shift; + + return $Name{$caller} if $Name{$caller}; + + my @parents = map { container_class($_) || () } @_; + + my $container_pkg = 'MooseX::ClassAttribute::Container::' . $caller; + + my $code = "package $container_pkg;\n"; + $code .= "use Moose;\n\n"; + + if (@parents) + { + $code .= "extends qw( @parents );\n"; + } + + $code .= <<'EOF'; + +my $Self; +sub instance +{ + return $Self ||= shift->new(@_); +} +EOF + -# 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; + eval $code; ## no critic ProhibitStringyEval + die $@ if $@; -sub register_implementation { 'MooseX::ClassAttribute' } + return $Name{$caller} = $container_pkg; + } + + sub container_class + { + my $pkg = shift || caller(); + + return $Name{$pkg}; + } +} + +# This is basically copied from Moose.pm +sub unimport ## no critic RequireFinalReturn +{ + my $caller = caller(); + + no strict 'refs'; ## no critic ProhibitNoStrict + foreach my $name (@EXPORT) + { + if ( defined &{ $caller . '::' . $name } ) + { + my $keyword = \&{ $caller . '::' . $name }; + + my $pkg_name = + eval { svref_2object($keyword)->GV()->STASH()->NAME() }; + + next if $@; + next if $pkg_name ne __PACKAGE__; + + delete ${ $caller . '::' }{$name}; + } + } +} 1; @@ -46,23 +122,66 @@ __END__ =head1 NAME -MooseX::ClassAttribute - The fantastic new MooseX::ClassAttribute! +MooseX::ClassAttribute - Declare class attributes Moose-style =head1 SYNOPSIS -Quick summary of what the module does. - -Perhaps a little code snippet. + package My::Class; + use Moose; use MooseX::ClassAttribute; - my $foo = MooseX::ClassAttribute->new(); + class_has 'Cache' => + ( is => 'rw', + isa => 'HashRef', + default => sub { {} }, + ); + + __PACKAGE__->meta()->make_immutable(); + MooseX::ClassAttribute::containing_class()->meta()->make_immutable(); + + no Moose; + no MooseX::ClassAttribute; + + # then later ... + + My::Class->Cache()->{thing} = ...; + + +=head1 DESCRIPTION + +This module allows you to declare class attributes in exactly the same +way as you declare object attributes, except using C +instead of C. It is also possible to make these attributes +immutable (and faster) just as you can with normal Moose attributes. + +You can use any feature of Moose's attribute declarations, including +overriding a parent's attributes, delegation (C), and +attribute metaclasses, and it should just work. + +=head1 FUNCTIONS + +This class exports one function when you use it, C. This +works exactly like Moose's C, but it declares class attributes. + +Own little nit is that if you include C in your class, you +won't remove the C function. To do that you must include +C as well. + +=head2 Implementation and Immutability + +Underneath the hood, this class creates one new class for each class +which has class attributes and sets up delegating methods in the class +for which you're creating class attributes. You don't need to worry +about this too much, except when it comes to making a class immutable. - ... +Since the class attributes are not really stored in your class, you +need to make the containing class immutable as well as your own ... -=head1 METHODS + __PACKAGE__->meta()->make_immutable(); + MooseX::ClassAttribute::containing_class()->meta()->make_immutable(); -This class provides the following methods +I =head1 AUTHOR @@ -70,10 +189,10 @@ Dave Rolsky, C<< >> =head1 BUGS -Please report any bugs or feature requests to C, -or through the web interface at L. I will be -notified, and then you'll automatically be notified of progress on -your bug as I make changes. +Please report any bugs or feature requests to +C, or through the web interface +at L. I will be notified, and then you'll +automatically be notified of progress on your bug as I make changes. =head1 COPYRIGHT & LICENSE diff --git a/lib/MooseX/ClassAttribute/Meta/Method/Accessor.pm b/lib/MooseX/ClassAttribute/Meta/Method/Accessor.pm deleted file mode 100644 index b9f4b95..0000000 --- a/lib/MooseX/ClassAttribute/Meta/Method/Accessor.pm +++ /dev/null @@ -1,46 +0,0 @@ -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; -} - - -1; diff --git a/t/02-immutable.t b/t/02-immutable.t index c91ce95..494289f 100644 --- a/t/02-immutable.t +++ b/t/02-immutable.t @@ -5,6 +5,7 @@ use lib 't/lib'; use SharedTests; -HasClassAttribute->meta()->make_immutable(); +HasClassAttribute->make_immutable(); +Child->make_immutable(); SharedTests::run_tests(); diff --git a/t/lib/SharedTests.pm b/t/lib/SharedTests.pm index 430fb1f..30928d0 100644 --- a/t/lib/SharedTests.pm +++ b/t/lib/SharedTests.pm @@ -4,7 +4,18 @@ use strict; use warnings; use Scalar::Util qw( isweak ); -use Test::More tests => 9; +use Test::More; + +my $HasMXAH; +BEGIN +{ + if ( eval 'use MooseX::AttributeHelpers; 1;' ) + { + $HasMXAH = 1; + } +} + +plan tests => 25; { @@ -13,32 +24,120 @@ use Test::More tests => 9; use Moose; use MooseX::ClassAttribute; - has 'ObjectCount' => - ( metaclass => 'ClassAttribute', - is => 'rw', + use vars qw($Lazy); + $Lazy = 0; + + class_has 'ObjectCount' => + ( is => 'rw', isa => 'Int', default => 0, ); - has 'WeakAttribute' => - ( metaclass => 'ClassAttribute', - is => 'rw', + class_has 'WeakAttribute' => + ( is => 'rw', isa => 'Object', weak_ref => 1, ); + class_has 'LazyAttribute' => + ( is => 'rw', + isa => 'Int', + lazy => 1, + # The side effect is used to test that this was called + # lazily. + default => sub { $Lazy = 1 }, + ); + + class_has 'ReadOnlyAttribute' => + ( is => 'ro', + isa => 'Int', + default => 10, + ); + + class_has 'ManyNames' => + ( is => 'rw', + isa => 'Int', + reader => 'M', + writer => 'SetM', + clearer => 'ClearM', + predicate => 'HasM', + ); + + class_has 'Delegatee' => + ( is => 'rw', + isa => 'Delegatee', + handles => [ 'units', 'color' ], + default => sub { Delegatee->new() }, + ); + + if ($HasMXAH) + { + class_has 'Mapping' => + ( metaclass => 'Collection::Hash', + is => 'rw', + isa => 'HashRef[Str]', + default => sub { {} }, + provides => + { exists => 'ExistsInMapping', + keys => 'IdsInMapping', + get => 'GetMapping', + set => 'SetMapping', + }, + ); + } + has 'size' => ( is => 'rw', isa => 'Int', default => 5, ); + no Moose; + no MooseX::ClassAttribute; + sub BUILD { my $self = shift; $self->ObjectCount( $self->ObjectCount() + 1 ); } + + sub make_immutable + { + my $class = shift; + + $class->meta()->make_immutable(); + MooseX::ClassAttribute::container_class()->meta()->make_immutable(); + Delegatee->meta()->make_immutable(); + } +} + +{ + package Delegatee; + + use Moose; + + has 'units' => + ( is => 'ro', + default => 5, + ); + + has 'color' => + ( is => 'ro', + default => 'blue', + ); +} + +{ + package Child; + + use Moose; + use MooseX::ClassAttribute; + + extends 'HasClassAttribute'; + + class_has '+ReadOnlyAttribute' => + ( default => 30 ); } sub run_tests @@ -65,10 +164,10 @@ sub run_tests } { - eval { HasClassAttribute->new( ObjectCount => 20 ) }; - like( $@, qr/\QCannot set a class attribute via the constructor (ObjectCount)/, - 'passing a class attribute to the constructor throws an error' ); - is( HasClassAttribute->ObjectCount(), 2, + my $hca3 = HasClassAttribute->new( ObjectCount => 20 ); + is( $hca3->ObjectCount(), 3, + 'class attributes passed to the constructor do not get set in the object' ); + is( HasClassAttribute->ObjectCount(), 3, 'class attributes are not affected by constructor params' ); } @@ -82,6 +181,78 @@ sub run_tests ok( ! defined HasClassAttribute->WeakAttribute(), 'weak class attributes are weak' ); } + + { + is( $HasClassAttribute::Lazy, 0, + '$HasClassAttribute::Lazy is 0' ); + + is( HasClassAttribute->LazyAttribute(), 1, + 'HasClassAttribute->LazyAttribute() is 1' ); + + is( $HasClassAttribute::Lazy, 1, + '$HasClassAttribute::Lazy is 1 after calling LazyAttribute' ); + } + + { + eval { HasClassAttribute->ReadOnlyAttribute(20) }; + like( $@, qr/\QCannot assign a value to a read-only accessor/, + 'cannot set read-only class attribute' ); + } + + { + is( Child->ReadOnlyAttribute(), 30, + q{Child class can extend parent's class attribute} ); + } + + { + ok( ! HasClassAttribute->HasM(), + 'HasM() returns false before M is set' ); + + HasClassAttribute->SetM(22); + + ok( HasClassAttribute->HasM(), + 'HasM() returns true after M is set' ); + is( HasClassAttribute->M(), 22, + 'M() returns 22' ); + + HasClassAttribute->ClearM(); + + ok( ! HasClassAttribute->HasM(), + 'HasM() returns false after M is cleared' ); + } + + { + isa_ok( HasClassAttribute->Delegatee(), 'Delegatee', + 'has a Delegetee object' ); + is( HasClassAttribute->units(), 5, + 'units() delegates to Delegatee and returns 5' ); + } + + { + ok( ! HasClassAttribute->can('class_has'), + q{'no MooseX::ClassAttribute' remove class_has from HasClassAttribute} ); + } + + SKIP: + { + skip 'These tests require MooseX::AttributeHelpers', 4 + unless $HasMXAH; + + my @ids = HasClassAttribute->IdsInMapping(); + is( scalar @ids, 0, + 'there are no keys in the mapping yet' ); + + ok( ! HasClassAttribute->ExistsInMapping('a'), + 'key does not exist in mapping' ); + + HasClassAttribute->SetMapping( a => 20 ); + + ok( HasClassAttribute->ExistsInMapping('a'), + 'key does exist in mapping' ); + + is( HasClassAttribute->GetMapping('a'), 20, + 'value for a in mapping is 20' ); + } } diff --git a/t/pod-coverage.t b/t/pod-coverage.t index aa1f35b..517c730 100644 --- a/t/pod-coverage.t +++ b/t/pod-coverage.t @@ -11,4 +11,4 @@ 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(); +all_pod_coverage_ok( { trustme => [ qr/^(?:class_has|container_class|unimport)$/ ] } );