From: Dave Rolsky Date: Tue, 2 Sep 2008 14:15:26 +0000 (+0000) Subject: Mostly working implementation, but mixing with MX::AH isn't working X-Git-Tag: 0.05~12 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?p=gitmo%2FMooseX-ClassAttribute.git;a=commitdiff_plain;h=bb70fe3ad64b3a6061784a338ead11df88eb9367 Mostly working implementation, but mixing with MX::AH isn't working --- diff --git a/lib/MooseX/ClassAttribute.pm b/lib/MooseX/ClassAttribute.pm index 7306caf..ba5e4bb 100644 --- a/lib/MooseX/ClassAttribute.pm +++ b/lib/MooseX/ClassAttribute.pm @@ -3,121 +3,45 @@ package MooseX::ClassAttribute; use strict; use warnings; -our $VERSION = '0.04'; +our $VERSION = '0.05'; our $AUTHORITY = 'cpan:DROLSKY'; -our @EXPORT = 'class_has'; ## no critic ProhibitAutomaticExportation -use base 'Exporter'; +use Moose (); +use Moose::Exporter; +use MooseX::ClassAttribute::Role::Meta::Class; -use B qw( svref_2object ); -use Moose::Meta::Class; -use Sub::Name; +Moose::Exporter->setup_import_methods + ( with_caller => [ 'class_has' ] ); -sub class_has ## no critic RequireArgUnpacking +sub init_meta { - my $caller = caller(); + shift; + my %p = @_; - process_class_attribute( $caller, @_ ); + Moose->init_meta(%p); - return; + return + Moose::Util::MetaRole::apply_metaclass_roles + ( for_class => $p{for_class}, + metaclass_roles => [ 'MooseX::ClassAttribute::Role::Meta::Class' ], + ); } -sub process_class_attribute ## no critic RequireArgUnpacking +sub class_has { - my $caller = shift; + my $caller = shift; + my $name = shift; + my %options = @_; - my $caller_meta = $caller->meta(); + my $attrs = ref $name eq 'ARRAY' ? $name : [$name]; - my @parents = $caller_meta->superclasses(); - - my $container_pkg = _make_container_class( $caller, @parents ); - my $container_meta = $container_pkg->meta(); - - $container_meta->add_attribute(@_); - - for my $meth ( grep { $_ ne 'instance' } $container_meta->get_method_list() ) - { - next if $caller_meta->has_method($meth); - - my $sub = sub { shift; - my $instance = $container_pkg->instance(); - return $instance->$meth(@_); }; - - $caller_meta->add_method( $meth => $sub ); - } - - return; + Class::MOP::Class + ->initialize($caller) + ->add_class_attribute( $_, %options ) + for @{ $attrs }; } -{ - # 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($_) || () } @_; - - push @parents, 'Moose::Object' - unless grep { $_->isa('Moose::Object') } @parents; - - my $container_pkg = 'MooseX::ClassAttribute::Container::' . $caller; - my $instance_holder = $container_pkg . '::Self'; - - my $instance_meth = sub { - no strict 'refs'; ## no critic ProhibitNoStrict - return $$instance_holder ||= shift->new(@_); - }; - - my $class = - Moose::Meta::Class->create - ( $container_pkg => - superclasses => \@parents, - methods => { instance => $instance_meth }, - ); - - 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, RequireArgUnpacking -{ - my $caller = Moose::_get_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; __END__ diff --git a/lib/MooseX/ClassAttribute/Meta/Attribute.pm b/lib/MooseX/ClassAttribute/Meta/Attribute.pm new file mode 100644 index 0000000..c6fe316 --- /dev/null +++ b/lib/MooseX/ClassAttribute/Meta/Attribute.pm @@ -0,0 +1,124 @@ +package MooseX::ClassAttribute::Meta::Attribute; + +use strict; +use warnings; + +use MooseX::ClassAttribute::Meta::Method::Accessor; + +use Moose; + +extends 'Moose::Meta::Attribute'; + + +sub accessor_metaclass { 'MooseX::ClassAttribute::Meta::Method::Accessor' } + +sub _process_options +{ + my $class = shift; + my $name = shift; + my $options = shift; + + confess 'A class attribute cannot be required' + if $options->{required}; + + return $class->SUPER::_process_options( $name, $options ); +} + +sub attach_to_class +{ + my $self = shift; + my $meta = shift; + + $self->SUPER::attach_to_class($meta); + + $self->_initialize($meta) + unless $self->is_lazy(); +} + +sub detach_from_class +{ + my $self = shift; + my $meta = shift; + + $self->clear_value($meta); + + $self->SUPER::detach_from_class($meta); +} + +sub _initialize +{ + my $self = shift; + + if ( $self->has_default() ) + { + $self->set_value( $self->default() ); + } + elsif ( $self->has_builder() ) + { + $self->set_value( $self->_call_builder() ); + } +} + +sub default +{ + my $self = shift; + + my $default = $self->SUPER::default(); + + if ( $self->is_default_a_coderef() ) + { + return $default->( $self->associated_class() ); + } + + return $default; +} + +sub _call_builder +{ + my $self = shift; + my $class = shift; + + my $builder = $self->builder(); + + return $class->$builder() + if $class->can( $self->builder ); + + confess( "$class does not support builder method '" + . $self->builder + . "' for attribute '" + . $self->name + . "'" ); +} + +sub set_value +{ + my $self = shift; + my $value = shift; + + $self->associated_class()->set_class_attribute_value( $self->name() => $value ); +} + +sub get_value +{ + my $self = shift; + + return $self->associated_class()->get_class_attribute_value( $self->name() ); +} + +sub has_value +{ + my $self = shift; + + return $self->associated_class()->has_class_attribute_value( $self->name() ); +} + +sub clear_value +{ + my $self = shift; + + return $self->associated_class()->clear_class_attribute_value( $self->name() ); +} + +no Moose; + +1; diff --git a/lib/MooseX/ClassAttribute/Meta/Method/Accessor.pm b/lib/MooseX/ClassAttribute/Meta/Method/Accessor.pm new file mode 100644 index 0000000..506f736 --- /dev/null +++ b/lib/MooseX/ClassAttribute/Meta/Method/Accessor.pm @@ -0,0 +1,116 @@ +package MooseX::ClassAttribute::Meta::Method::Accessor; + +use strict; +use warnings; + +use Moose; + +extends 'Moose::Meta::Method::Accessor'; + + +sub generate_predicate_method_inline +{ + my $attr = (shift)->associated_attribute; + my $attr_name = $attr->name; + + my $code = + eval 'sub {' + . $attr->associated_class()->inline_is_class_slot_initialized( "'$attr_name'" ) + . '}'; + + confess "Could not generate inline predicate because : $@" if $@; + + return $code; +} + +sub generate_clearer_method_inline +{ + my $attr = (shift)->associated_attribute; + my $attr_name = $attr->name; + my $meta_instance = $attr->associated_class->instance_metaclass; + + my $code = + eval 'sub {' + . $attr->associated_class()->inline_deinitialize_class_slot( "'$attr_name'" ) + . '}'; + + confess "Could not generate inline clearer because : $@" if $@; + + return $code; +} + +sub _inline_store +{ + my $self = shift; + shift; + my $value = shift; + + my $attr = $self->associated_attribute(); + + my $slot_name = sprintf "'%s'", $attr->slots(); + + my $meta = $attr->associated_class(); + + my $code = $meta->inline_set_class_slot_value($slot_name, $value) . ";"; + $code .= $meta->inline_weaken_class_slot_value($slot_name, $value) . ";" + if $attr->is_weak_ref(); + + return $code; +} + +sub _inline_get +{ + my $self = shift; + + my $attr = $self->associated_attribute; + my $meta = $attr->associated_class(); + + my $slot_name = sprintf "'%s'", $attr->slots; + + return $meta->inline_get_class_slot_value($slot_name); +} + +sub _inline_access +{ + my $self = shift; + + my $attr = $self->associated_attribute; + my $meta = $attr->associated_class(); + + my $slot_name = sprintf "'%s'", $attr->slots; + + return $meta->inline_class_slot_access($slot_name); +} + +sub _inline_has +{ + my $self = shift; + + my $attr = $self->associated_attribute; + my $meta = $attr->associated_class(); + + my $slot_name = sprintf "'%s'", $attr->slots; + + return $meta->inline_is_class_slot_initialized($slot_name); +} + +sub _inline_init_slot +{ + my $self = shift; + + return $self->_inline_store( undef, $_[-1] ); +} + +sub _inline_check_lazy +{ + my $self = shift; + + return + $self->SUPER::_inline_check_lazy + ( q{'} . $self->associated_attribute()->associated_class()->name() . q{'} ); +} + +no Moose; + +1; + diff --git a/lib/MooseX/ClassAttribute/Role/Meta/Class.pm b/lib/MooseX/ClassAttribute/Role/Meta/Class.pm new file mode 100644 index 0000000..e486b00 --- /dev/null +++ b/lib/MooseX/ClassAttribute/Role/Meta/Class.pm @@ -0,0 +1,243 @@ +package MooseX::ClassAttribute::Role::Meta::Class; + +use strict; +use warnings; + +use MooseX::AttributeHelpers; +use Scalar::Util qw( blessed ); + +use Moose::Role; + + +has class_attribute_map => + ( metaclass => 'Collection::Hash', + is => 'ro', + isa => 'HashRef[MooseX::ClassAttribute::Meta::Attribute]', + provides => { set => '_add_class_attribute', + exists => 'has_class_attribute', + get => 'get_class_attribute', + delete => '_remove_class_attribute', + keys => 'get_class_attribute_list', + }, + default => sub { {} }, + reader => 'get_class_attribute_map', + ); + +has _class_attribute_values => + ( metaclass => 'Collection::Hash', + is => 'ro', + isa => 'HashRef', + provides => { get => 'get_class_attribute_value', + set => 'set_class_attribute_value', + exists => 'has_class_attribute_value', + delete => 'clear_class_attribute_value', + }, + lazy => 1, + default => sub { $_[0]->_class_attribute_values_hashref() }, + ); + + +sub add_class_attribute +{ + my $self = shift; + + my $attr = + blessed $_[0] && $_[0]->isa('Class::MOP::Attribute') + ? $_[0] + : $self->_process_class_attribute(@_); + + my $name = $attr->name(); + + $self->remove_class_attribute($name) + if $self->has_class_attribute($name); + + $attr->attach_to_class($self); + + $self->_add_class_attribute( $name => $attr ); + + my $e = do { local $@; eval { $attr->install_accessors() }; $@ }; + + if ( $e ) + { + $self->remove_attribute($name); + die $e; + } + + return $attr; +} + +# It'd be nice if I didn't have to replicate this for class +# attributes, since it's basically just a copy of +# Moose::Meta::Class->_process_attribute +sub _process_class_attribute +{ + my $self = shift; + my $name = shift; + my @args = @_; + + @args = %{$args[0]} if scalar @args == 1 && ref($args[0]) eq 'HASH'; + + if ($name =~ /^\+(.*)/) + { + return $self->_process_inherited_class_attribute( $1, @args ); + } + else + { + return $self->_process_new_class_attribute( $name, @args ); + } +} + +sub _process_new_class_attribute +{ + my $self = shift; + my $name = shift; + my %p = @_; + + if ( $p{metaclass} ) + { + $p{metaclass} = + Moose::Meta::Class->create_anon_class + ( superclasses => [ 'MooseX::ClassAttribute::Meta::Attribute', $p{metaclass} ], + cache => 1, + )->name(); + } + else + { + $p{metaclass} = 'MooseX::ClassAttribute::Meta::Attribute'; + } + + return Moose::Meta::Attribute->interpolate_class_and_new( $name, %p ); +} + +sub _process_inherited_class_attribute +{ + my $self = shift; + my $name = shift; + my %p = @_; + + my $inherited_attr = $self->find_class_attribute_by_name($name); + + (defined $inherited_attr) + || confess "Could not find an attribute by the name of '$name' to inherit from"; + + return $inherited_attr->clone_and_inherit_options(%p); +} + +sub remove_class_attribute +{ + my $self = shift; + my $name = shift; + + (defined $name && $name) + || confess 'You must provide an attribute name'; + + my $removed_attr = $self->get_class_attribute($name); + return unless $removed_attr; + + $self->_remove_class_attribute($name); + + $removed_attr->remove_accessors(); + $removed_attr->detach_from_class(); + + return $removed_attr; +} + +sub get_all_class_attributes +{ + shift->compute_all_applicable_class_attributes(@_); +} + +sub compute_all_applicable_class_attributes +{ + my $self = shift; + + my %attrs = + map { %{ Class::MOP::Class->initialize($_)->get_class_attribute_map } } + reverse $self->linearized_isa; + + return values %attrs; +} + +sub find_class_attribute_by_name +{ + my $self = shift; + my $name = shift; + + foreach my $class ( $self->linearized_isa() ) + { + my $meta = Class::MOP::Class->initialize($class); + + return $meta->get_class_attribute($name) + if $meta->has_class_attribute($name); + } + + return; +} + +sub _class_attribute_values_hashref +{ + my $self = shift; + + no strict 'refs'; + return \%{ $self->_class_attribute_var_name() }; +} + +sub _class_attribute_var_name +{ + my $self = shift; + + return $self->name() . q'::__ClassAttributeValues'; +} + +sub inline_class_slot_access +{ + my $self = shift; + my $name = shift; + + return '$' . $self->_class_attribute_var_name . '{' . $name . '}'; +} + +sub inline_get_class_slot_value +{ + my $self = shift; + my $name = shift; + + return $self->inline_class_slot_access($name); +} + +sub inline_set_class_slot_value +{ + my $self = shift; + my $name = shift; + my $val_name = shift; + + return $self->inline_class_slot_access($name) . ' = ' . $val_name; +} + +sub inline_is_class_slot_initialized +{ + my $self = shift; + my $name = shift; + + return 'exists ' . $self->inline_class_slot_access($name); +} + +sub inline_deinitialize_class_slot +{ + my $self = shift; + my $name = shift; + + return 'delete ' . $self->inline_class_slot_access($name); +} + +sub inline_weaken_class_slot_value +{ + my $self = shift; + my $name = shift; + + return 'Scalar::Util::weaken( ' . $self->inline_class_slot_access($name) . ')'; +} + +no Moose::Role; + +1;