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__
--- /dev/null
+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;
--- /dev/null
+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;
+
--- /dev/null
+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;
projects / gitmo/MooseX-ClassAttribute.git / commitdiff