use Moose 0.89 ();
use Moose::Exporter;
use MooseX::ClassAttribute::Role::Meta::Class;
+use MooseX::ClassAttribute::Role::Meta::Role;
+use MooseX::ClassAttribute::Role::Meta::Application::ToClass;
+use MooseX::ClassAttribute::Role::Meta::Application::ToRole;
+use MooseX::ClassAttribute::Role::Meta::Application::ToInstance;
Moose::Exporter->setup_import_methods( with_meta => ['class_has'] );
},
role_metaroles => {
role => ['MooseX::ClassAttribute::Role::Meta::Role'],
+ application_to_class =>
+ ['MooseX::ClassAttribute::Role::Meta::Application::ToClass'],
+ application_to_role =>
+ ['MooseX::ClassAttribute::Role::Meta::Application::ToRole'],
+ application_to_instance => [
+ 'MooseX::ClassAttribute::Role::Meta::Application::ToInstance'
+ ],
},
);
}
--- /dev/null
+package MooseX::ClassAttribute::Meta::Role::Attribute;
+
+use strict;
+use warnings;
+
+use List::MoreUtils qw( uniq );
+
+use namespace::autoclean;
+use Moose;
+
+extends 'Moose::Meta::Role::Attribute';
+
+sub new {
+ my ( $class, $name, %options ) = @_;
+
+ $options{traits} = [
+ uniq( @{ $options{traits} || [] } ),
+ 'MooseX::ClassAttribute::Role::Meta::Attribute'
+ ];
+
+ return $class->SUPER::new( $name, %options );
+}
+
+1;
--- /dev/null
+package MooseX::ClassAttribute::Role::Meta::Application;
+
+use strict;
+use warnings;
+
+use namespace::autoclean;
+use Moose::Role;
+
+after apply_attributes => sub {
+ shift->apply_class_attributes(@_);
+};
+
+1;
--- /dev/null
+package MooseX::ClassAttribute::Role::Meta::Application::ToClass;
+
+use strict;
+use warnings;
+
+use namespace::autoclean;
+use Moose::Role;
+
+with 'MooseX::ClassAttribute::Role::Meta::Application';
+
+sub apply_class_attributes {
+ my $self = shift;
+ my $role = shift;
+ my $class = shift;
+
+ $class = Moose::Util::MetaRole::apply_metaclass_roles(
+ for => $class,
+ class_metaroles => {
+ class => ['MooseX::ClassAttribute::Role::Meta::Class'],
+ },
+ );
+
+ my $attr_metaclass = $class->attribute_metaclass();
+
+ foreach my $attribute_name ( $role->get_class_attribute_list() ) {
+ if ( $class->has_class_attribute($attribute_name)
+ && $class->get_class_attribute($attribute_name)
+ != $role->get_class_attribute($attribute_name) ) {
+ next;
+ }
+ else {
+ $class->add_class_attribute(
+ $role->get_class_attribute($attribute_name)
+ ->attribute_for_class($attr_metaclass) );
+ }
+ }
+}
+
+1;
--- /dev/null
+package MooseX::ClassAttribute::Role::Meta::Application::ToInstance;
+
+use strict;
+use warnings;
+
+use Class::MOP;
+
+use namespace::autoclean;
+use Moose::Role;
+
+after apply => sub {
+ shift->apply_class_attributes(@_);
+};
+
+sub apply_class_attributes {
+ my $self = shift;
+ my $role = shift;
+ my $object = shift;
+
+ my $class = Moose::Util::MetaRole::apply_metaclass_roles(
+ for => ref $object,
+ class_metaroles => {
+ class => ['MooseX::ClassAttribute::Role::Meta::Class'],
+ },
+ );
+
+ my $attr_metaclass = $class->attribute_metaclass();
+
+ foreach my $attribute_name ( $role->get_class_attribute_list() ) {
+ if ( $class->has_class_attribute($attribute_name)
+ && $class->get_class_attribute($attribute_name)
+ != $role->get_class_attribute($attribute_name) ) {
+ next;
+ }
+ else {
+ $class->add_class_attribute(
+ $role->get_class_attribute($attribute_name)
+ ->attribute_for_class($attr_metaclass) );
+ }
+ }
+}
+
+1;
--- /dev/null
+package MooseX::ClassAttribute::Role::Meta::Application::ToRole;
+
+use strict;
+use warnings;
+
+use Moose::Util::MetaRole;
+use MooseX::ClassAttribute::Role::Meta::Application::ToClass;
+use MooseX::ClassAttribute::Role::Meta::Application::ToInstance;
+
+use namespace::autoclean;
+use Moose::Role;
+
+with 'MooseX::ClassAttribute::Role::Meta::Application';
+
+sub apply_class_attributes {
+ my $self = shift;
+ my $role1 = shift;
+ my $role2 = shift;
+
+ $role2 = Moose::Util::MetaRole::apply_metaclass_roles(
+ for => $role2,
+ role_metaroles => {
+ role => ['MooseX::ClassAttribute::Role::Meta::Role'],
+ application_to_class =>
+ ['MooseX::ClassAttribute::Role::Meta::Application::ToClass'],
+ application_to_role =>
+ ['MooseX::ClassAttribute::Role::Meta::Application::ToRole'],
+ application_to_instance => [
+ 'MooseX::ClassAttribute::Role::Meta::Application::ToInstance'
+ ],
+ },
+ );
+
+ foreach my $attribute_name ( $role1->get_class_attribute_list() ) {
+ if ( $role2->has_class_attribute($attribute_name)
+ && $role2->get_class_attribute($attribute_name)
+ != $role1->get_class_attribute($attribute_name) ) {
+
+ require Moose;
+ Moose->throw_error( "Role '"
+ . $role1->name()
+ . "' has encountered a class attribute conflict "
+ . "during composition. This is fatal error and cannot be disambiguated."
+ );
+ }
+ else {
+ $role2->add_class_attribute(
+ $role1->get_class_attribute($attribute_name)->clone() );
+ }
+ }
+}
+
+1;
use MooseX::ClassAttribute::Meta::Method::Accessor;
+use namespace::autoclean;
use Moose::Role;
# This is the worst role evar! Really, this should be a subclass,
# because it overrides a lot of behavior. However, as a subclass it
# won't cooperate with _other_ subclasses.
-around 'accessor_metaclass' => sub
-{
+around 'accessor_metaclass' => sub {
return 'MooseX::ClassAttribute::Meta::Method::Accessor';
};
-around '_process_options' => sub
-{
+around '_process_options' => sub {
my $orig = shift;
my $class = shift;
my $name = shift;
return $class->$orig( $name, $options );
};
-around attach_to_class => sub
-{
+around attach_to_class => sub {
my $orig = shift;
my $self = shift;
my $meta = shift;
unless $self->is_lazy();
};
-around 'detach_from_class' => sub
-{
+around 'detach_from_class' => sub {
my $orig = shift;
my $self = shift;
my $meta = shift;
$self->$orig($meta);
};
-sub _initialize
-{
+sub _initialize {
my $self = shift;
my $metaclass = shift;
- if ( $self->has_default() )
- {
+ if ( $self->has_default() ) {
$self->set_value( undef, $self->default() );
}
- elsif ( $self->has_builder() )
- {
+ elsif ( $self->has_builder() ) {
$self->set_value( undef, $self->_call_builder( $metaclass->name() ) );
}
}
-around 'default' => sub
-{
+around 'default' => sub {
my $orig = shift;
my $self = shift;
my $default = $self->$orig();
- if ( $self->is_default_a_coderef() )
- {
+ if ( $self->is_default_a_coderef() ) {
return $default->( $self->associated_class() );
}
return $default;
};
-around '_call_builder' => sub
-{
+around '_call_builder' => sub {
shift;
my $self = shift;
my $class = shift;
. "'" );
};
-around 'set_value' => sub
-{
+around 'set_value' => sub {
shift;
- my $self = shift;
- shift; # ignoring instance or class name
- my $value = shift;
+ my $self = shift;
+ shift; # ignoring instance or class name
+ my $value = shift;
- $self->associated_class()->set_class_attribute_value( $self->name() => $value );
+ $self->associated_class()
+ ->set_class_attribute_value( $self->name() => $value );
};
-around 'get_value' => sub
-{
+around 'get_value' => sub {
shift;
- my $self = shift;
+ my $self = shift;
- return $self->associated_class()->get_class_attribute_value( $self->name() );
+ return $self->associated_class()
+ ->get_class_attribute_value( $self->name() );
};
-around 'has_value' => sub
-{
+around 'has_value' => sub {
shift;
- my $self = shift;
+ my $self = shift;
- return $self->associated_class()->has_class_attribute_value( $self->name() );
+ return $self->associated_class()
+ ->has_class_attribute_value( $self->name() );
};
-around 'clear_value' => sub
-{
+around 'clear_value' => sub {
shift;
- my $self = shift;
+ my $self = shift;
- return $self->associated_class()->clear_class_attribute_value( $self->name() );
+ return $self->associated_class()
+ ->clear_class_attribute_value( $self->name() );
};
-no Moose::Role;
-
1;
__END__
has _class_attribute_map => (
traits => ['Hash'],
is => 'ro',
- isa => 'HashRef[Moose::Meta::Attribute]',
+ isa => 'HashRef[Class::MOP::Mixin::AttributeCore]',
handles => {
'_add_class_attribute' => 'set',
'has_class_attribute' => 'exists',
--- /dev/null
+package MooseX::ClassAttribute::Role::Meta::Role;
+
+use strict;
+use warnings;
+
+use MooseX::ClassAttribute::Meta::Role::Attribute;
+use Scalar::Util qw( blessed );
+
+use namespace::autoclean;
+use Moose::Role;
+
+with 'MooseX::ClassAttribute::Role::Meta::Mixin::HasClassAttributes';
+
+around add_class_attribute => sub {
+ my $orig = shift;
+ my $self = shift;
+ my $attr = (
+ blessed $_[0] && $_[0]->isa('Class::MOP::Mixin::AttributeCore')
+ ? $_[0]
+ : MooseX::ClassAttribute::Meta::Role::Attribute->new(@_)
+ );
+
+ $self->$orig($attr);
+
+ return $attr;
+};
+
+sub _attach_class_attribute {
+ my ( $self, $attribute ) = @_;
+
+ $attribute->attach_to_role($self);
+}
+
+1;
+
+__END__
+
+=pod
+
+=head1 NAME
+
+MooseX::ClassAttribute::Role::Meta::Class - A metaclass role for classes with class attributes
+
+=head1 SYNOPSIS
+
+ for my $attr ( HasClassAttributes->meta()->get_all_class_attributes() )
+ {
+ print $attr->name();
+ }
+
+=head1 DESCRIPTION
+
+This role adds awareness of class attributes to a metaclass object. It
+provides a set of introspection methods that largely parallel the
+existing attribute methods, except they operate on class attributes.
+
+=head1 METHODS
+
+Every method provided by this role has an analogous method in
+C<Class::MOP::Class> or C<Moose::Meta::Class> for regular attributes.
+
+=head2 $meta->has_class_attribute($name)
+
+=head2 $meta->get_class_attribute($name)
+
+=head2 $meta->get_class_attribute_list()
+
+=head2 $meta->get_class_attribute_map()
+
+These methods operate on the current metaclass only.
+
+=head2 $meta->add_class_attribute(...)
+
+This accepts the same options as the L<Moose::Meta::Attribute>
+C<add_attribute()> method. However, if an attribute is specified as
+"required" an error will be thrown.
+
+=head2 $meta->remove_class_attribute($name)
+
+If the named class attribute exists, it is removed from the class,
+along with its accessor methods.
+
+=head2 $meta->get_all_class_attributes()
+
+This method returns a list of attribute objects for the class and all
+its parent classes.
+
+=head2 $meta->find_class_attribute_by_name($name)
+
+This method looks at the class and all its parent classes for the
+named class attribute.
+
+=head2 $meta->get_class_attribute_value($name)
+
+=head2 $meta->set_class_attribute_value($name, $value)
+
+=head2 $meta->set_class_attribute_value($name)
+
+=head2 $meta->clear_class_attribute_value($name)
+
+These methods operate on the storage for class attribute values, which
+is attached to the metaclass object.
+
+There's really no good reason for you to call these methods unless
+you're doing some deep hacking. They are named as public methods
+solely because they are used by other meta roles and classes in this
+distribution.
+
+=head2 inline_class_slot_access($name)
+
+=head2 inline_get_class_slot_value($name)
+
+=head2 inline_set_class_slot_value($name, $val_name)
+
+=head2 inline_is_class_slot_initialized($name)
+
+=head2 inline_deinitialize_class_slot($name)
+
+=head2 inline_weaken_class_slot_value($name)
+
+These methods return code snippets for inlining.
+
+There's really no good reason for you to call these methods unless
+you're doing some deep hacking. They are named as public methods
+solely because they are used by other meta roles and classes in this
+distribution.
+
+=head1 AUTHOR
+
+Dave Rolsky, C<< <autarch@urth.org> >>
+
+=head1 BUGS
+
+See L<MooseX::ClassAttribute> for details.
+
+=head1 COPYRIGHT & LICENSE
+
+Copyright 2007-2008 Dave Rolsky, All Rights Reserved.
+
+This program is free software; you can redistribute it and/or modify
+it under the same terms as Perl itself.
+
+=cut
use lib 't/lib';
use SharedTests;
+use Test::More;
SharedTests::run_tests();
+
+done_testing();
use lib 't/lib';
use SharedTests;
+use Test::More;
HasClassAttribute->meta()->make_immutable();
Child->meta()->make_immutable();
SharedTests::run_tests();
+
+done_testing();
Built
LazyBuilt
Triggerish
+ TriggerRecord
);
is_deeply(
--- /dev/null
+use strict;
+use warnings;
+
+use lib 't/lib';
+
+use SharedTests;
+use Test::More;
+
+use Moose::Util qw( apply_all_roles );
+
+{
+ package RoleHCA;
+
+ use Moose::Role;
+ use MooseX::ClassAttribute;
+
+ while ( my ( $name, $def ) = each %SharedTests::Attrs ) {
+ class_has $name => %{$def};
+ }
+}
+
+{
+ package ClassWithRoleHCA;
+
+ use Moose;
+
+ with 'RoleHCA';
+
+ has 'size' => (
+ is => 'rw',
+ isa => 'Int',
+ default => 5,
+ );
+
+ sub BUILD {
+ my $self = shift;
+
+ $self->ObjectCount( $self->ObjectCount() + 1 );
+ }
+
+ sub _BuildIt {42}
+
+ sub _CallTrigger {
+ push @{ $_[0]->TriggerRecord() }, [@_];
+ }
+}
+
+SharedTests::run_tests('ClassWithRoleHCA');
+
+# These next tests are aimed at testing to-role application followed by
+# to-class application
+{
+ package RoleWithRoleHCA;
+
+ use Moose::Role;
+ use MooseX::ClassAttribute;
+
+ with 'RoleHCA';
+}
+
+{
+ package ClassWithRoleWithRoleHCA;
+
+ use Moose;
+
+ with 'RoleWithRoleHCA';
+
+ has 'size' => (
+ is => 'rw',
+ isa => 'Int',
+ default => 5,
+ );
+
+ sub BUILD {
+ my $self = shift;
+
+ $self->ObjectCount( $self->ObjectCount() + 1 );
+ }
+
+ sub _BuildIt {42}
+
+ sub _CallTrigger {
+ push @{ $_[0]->TriggerRecord() }, [@_];
+ }
+}
+
+SharedTests::run_tests('ClassWithRoleWithRoleHCA');
+
+{
+ package InstanceWithRoleHCA;
+
+ use Moose;
+
+ has 'size' => (
+ is => 'rw',
+ isa => 'Int',
+ default => 5,
+ );
+
+ sub _BuildIt {42}
+
+ sub _CallTrigger {
+ push @{ $_[0]->TriggerRecord() }, [@_];
+ }
+}
+
+my $instance = InstanceWithRoleHCA->new();
+
+apply_all_roles( $instance, 'RoleHCA' );
+
+$instance->ObjectCount(1);
+
+SharedTests::run_tests($instance);
+
+done_testing();
use Test::More;
use vars qw($Lazy);
-$Lazy = 0;
our %Attrs = (
ObjectCount => {
is => 'rw',
trigger => sub { shift->_CallTrigger(@_) },
},
+ TriggerRecord => {
+ is => 'ro',
+ default => sub { [] },
+ },
);
{
sub _BuildIt {42}
- our @Triggered;
-
sub _CallTrigger {
- push @Triggered, [@_];
+ push @{ $_[0]->TriggerRecord() }, [@_];
}
sub make_immutable {
}
sub run_tests {
- my $class = shift || 'HasClassAttribute';
+ my $thing = shift || 'HasClassAttribute';
local $Test::Builder::Level = $Test::Builder::Level + 1;
+ $Lazy = 0;
+
+ my $count = ref $thing ? 1 : 0;
+
{
is(
- $class->ObjectCount(), 0,
+ $thing->ObjectCount(), $count,
'ObjectCount() is 0'
);
- my $hca1 = $class->new();
- is(
- $hca1->size(), 5,
- 'size is 5 - object attribute works as expected'
- );
- is(
- $class->ObjectCount(), 1,
- 'ObjectCount() is 1'
- );
-
- my $hca2 = $class->new( size => 10 );
- is(
- $hca2->size(), 10,
- 'size is 10 - object attribute can be set via constructor'
- );
- is(
- $class->ObjectCount(), 2,
- 'ObjectCount() is 2'
- );
- is(
- $hca2->ObjectCount(), 2,
- 'ObjectCount() is 2 - can call class attribute accessor on object'
- );
+ unless ( ref $thing ) {
+ my $hca1 = $thing->new();
+ is(
+ $hca1->size(), 5,
+ 'size is 5 - object attribute works as expected'
+ );
+ is(
+ $thing->ObjectCount(), 1,
+ 'ObjectCount() is 1'
+ );
+
+ my $hca2 = $thing->new( size => 10 );
+ is(
+ $hca2->size(), 10,
+ 'size is 10 - object attribute can be set via constructor'
+ );
+ is(
+ $thing->ObjectCount(), 2,
+ 'ObjectCount() is 2'
+ );
+ is(
+ $hca2->ObjectCount(), 2,
+ 'ObjectCount() is 2 - can call class attribute accessor on object'
+ );
+ }
}
- {
- my $hca3 = $class->new( ObjectCount => 20 );
+ unless ( ref $thing ) {
+ my $hca3 = $thing->new( ObjectCount => 20 );
is(
$hca3->ObjectCount(), 3,
'class attributes passed to the constructor do not get set in the object'
);
is(
- $class->ObjectCount(), 3,
+ $thing->ObjectCount(), 3,
'class attributes are not affected by constructor params'
);
}
{
my $object = bless {}, 'Thing';
- $class->WeakAttribute($object);
+ $thing->WeakAttribute($object);
undef $object;
ok(
- !defined $class->WeakAttribute(),
+ !defined $thing->WeakAttribute(),
'weak class attributes are weak'
);
}
);
is(
- $class->LazyAttribute(), 1,
- '$class->LazyAttribute() is 1'
+ $thing->LazyAttribute(), 1,
+ '$thing->LazyAttribute() is 1'
);
is(
}
{
- eval { $class->ReadOnlyAttribute(20) };
+ eval { $thing->ReadOnlyAttribute(20) };
like(
$@, qr/\QCannot assign a value to a read-only accessor/,
'cannot set read-only class attribute'
{
ok(
- !$class->HasM(),
+ !$thing->HasM(),
'HasM() returns false before M is set'
);
- $class->SetM(22);
+ $thing->SetM(22);
ok(
- $class->HasM(),
+ $thing->HasM(),
'HasM() returns true after M is set'
);
is(
- $class->M(), 22,
+ $thing->M(), 22,
'M() returns 22'
);
- $class->ClearM();
+ $thing->ClearM();
ok(
- !$class->HasM(),
+ !$thing->HasM(),
'HasM() returns false after M is cleared'
);
}
{
isa_ok(
- $class->Delegatee(), 'Delegatee',
+ $thing->Delegatee(), 'Delegatee',
'has a Delegetee object'
);
is(
- $class->units(), 5,
+ $thing->units(), 5,
'units() delegates to Delegatee and returns 5'
);
}
{
- my @ids = $class->IdsInMapping();
+ my @ids = $thing->IdsInMapping();
is(
scalar @ids, 0,
'there are no keys in the mapping yet'
);
ok(
- !$class->ExistsInMapping('a'),
+ !$thing->ExistsInMapping('a'),
'key does not exist in mapping'
);
- $class->SetMapping( a => 20 );
+ $thing->SetMapping( a => 20 );
ok(
- $class->ExistsInMapping('a'),
+ $thing->ExistsInMapping('a'),
'key does exist in mapping'
);
is(
- $class->GetMapping('a'), 20,
+ $thing->GetMapping('a'), 20,
'value for a in mapping is 20'
);
}
{
is(
- $class->Built(), 42,
+ $thing->Built(), 42,
'attribute with builder works'
);
is(
- $class->LazyBuilt(), 42,
+ $thing->LazyBuilt(), 42,
'attribute with lazy builder works'
);
}
{
- $class->Triggerish(42);
- my $triggered = do { no strict 'refs'; \@{ $class . '::Triggered' } };
- is( scalar @{$triggered}, 1, 'trigger was called' );
- is( $class->Triggerish(), 42, 'Triggerish is now 42' );
+ $thing->Triggerish(42);
- $class->Triggerish(84);
- is( $class->Triggerish(), 84, 'Triggerish is now 84' );
+ is( scalar @{ $thing->TriggerRecord() }, 1, 'trigger was called' );
+ is( $thing->Triggerish(), 42, 'Triggerish is now 42' );
+
+ $thing->Triggerish(84);
+ is( $thing->Triggerish(), 84, 'Triggerish is now 84' );
is_deeply(
- $triggered,
+ $thing->TriggerRecord(),
[
- [ $class, qw( 42 ) ],
- [ $class, qw( 84 42 ) ],
+ [ $thing, qw( 42 ) ],
+ [ $thing, qw( 84 42 ) ],
],
'trigger passes old value correctly'
);
}
-
- done_testing();
}
1;
projects / gitmo/MooseX-ClassAttribute.git / commitdiff