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;
=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<class_has()>
+instead of C<has()>. 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<handles>), and
+attribute metaclasses, and it should just work.
+
+=head1 FUNCTIONS
+
+This class exports one function when you use it, C<class_has()>. This
+works exactly like Moose's C<has()>, but it declares class attributes.
+
+Own little nit is that if you include C<no Moose> in your class, you
+won't remove the C<class_has()> function. To do that you must include
+C<no MooseX::ClassAttribute> 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<This may change in the future!>
=head1 AUTHOR
=head1 BUGS
-Please report any bugs or feature requests to C<bug-moosex-classattribute@rt.cpan.org>,
-or through the web interface at L<http://rt.cpan.org>. 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<bug-moosex-classattribute@rt.cpan.org>, or through the web interface
+at L<http://rt.cpan.org>. I will be notified, and then you'll
+automatically be notified of progress on your bug as I make changes.
=head1 COPYRIGHT & LICENSE
+++ /dev/null
-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;
use SharedTests;
-HasClassAttribute->meta()->make_immutable();
+HasClassAttribute->make_immutable();
+Child->make_immutable();
SharedTests::run_tests();
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;
{
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
}
{
- 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' );
}
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' );
+ }
}
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)$/ ] } );
projects / gitmo/MooseX-ClassAttribute.git / commitdiff