moose 1.21 and 1.9 compatible

[gitmo/MooseX-ClassAttribute.git] / lib / MooseX / ClassAttribute / Trait / Attribute.pm

package MooseX::ClassAttribute::Trait::Attribute;

use strict;
use warnings;

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 '_process_options' => sub {
    my $orig    = shift;
    my $class   = shift;
    my $name    = shift;
    my $options = shift;

    confess 'A class attribute cannot be required'
        if $options->{required};

    return $class->$orig( $name, $options );
};

around 'attach_to_class' => sub {
    my $orig = shift;
    my $self = shift;
    my $meta = shift;

    $self->$orig($meta);
    $self->initialize_instance_slot($meta, $meta->name);
};

override set_initial_value => sub {
    my ($self, $instance, $value) = @_;
    $self->_set_initial_slot_value(
        $self,
        $instance,
        $value
    );
};


before 'detach_from_class' => sub {
    shift->clear_value(shift);
};

sub set_slot_value { $_[0]->set_value($_[0], $_[3]) }

around 'set_value' => sub {
    shift;
    my $self = shift;
    shift;    # ignoring instance or class name
    my $value = shift;
    $self->associated_class()
        ->set_class_attribute_value( $self->name() => $value );
};

around 'get_value' => sub {
    shift;
    my $self = shift;

    return $self->associated_class()
        ->get_class_attribute_value( $self->name() );
};

around 'has_value' => sub {
    shift;
    my $self = shift;

    return $self->associated_class()
        ->has_class_attribute_value( $self->name() );
};

around 'clear_value' => sub {
    shift;
    my $self = shift;

    return $self->associated_class()
        ->clear_class_attribute_value( $self->name() );
};


sub _inline_instance_get {}
sub inline_get {}
around ['inline_get', '_inline_instance_get'] => sub {
    my ($orig, $self) = @_;

    return $self->associated_class()
        ->inline_get_class_slot_value( $self->slots() );
};

sub _inline_weaken_value {}
around ['_inline_weaken_value'] => sub {
    my ($orig, $self, $instance, $value) = @_;
    return '' unless $self->is_weak_ref;
    return
        $self->associated_class->inline_weaken_class_slot_value( $self->slots() )
           . 'if ref ' . $value . ';';
};

sub _inline_instance_set {}
around ['_inline_instance_set'] => sub {
    my ($orig, $self, undef, $value) = @_;

    my $meta = $self->associated_class();

    my $code
        = $meta->inline_set_class_slot_value( $self->slots(), $value ) . ";";

    return $code;
};

sub inline_set {}
around ['inline_set'] => sub {
    my ($orig, $self, undef, $value) = @_;

    my $meta = $self->associated_class();

    my $code
        = $meta->inline_set_class_slot_value( $self->slots(), $value ) . ";";
    $code
        .= $self->_inline_weaken_value( $self->slots(), $value );

    return $code;
};

sub _inline_instance_has {}
sub inline_has {}
around ['inline_has', '_inline_instance_has'] => sub {
    my ($orig, $self) = @_;

    return $self->associated_class()
        ->inline_is_class_slot_initialized( $self->slots() );
};

sub _inline_clear_value {}
sub inline_clear {}
around ['inline_clear', '_inline_clear_value'] => sub {
    my ($orig, $self) = @_;

    return $self->associated_class()
        ->inline_deinitialize_class_slot( $self->slots() );
};

1;

# ABSTRACT: A trait for class attributes

__END__

=pod

=head1 DESCRIPTION

This role modifies the behavior of class attributes in various
ways. It really should be a subclass of C<Moose::Meta::Attribute>, but
if it were then it couldn't be combined with other attribute
metaclasses, like C<MooseX::AttributeHelpers>.

There are no new public methods implemented by this role. All it does
is change the behavior of a number of existing methods.

=head1 BUGS

See L<MooseX::ClassAttribute> for details.

=cut