lib/MooseX/ClassAttribute/Trait/Attribute.pm

   1 package MooseX::ClassAttribute::Trait::Attribute;
   2
   3 use strict;
   4 use warnings;
   5
   6 use namespace::autoclean;
   7 use Moose::Role;
   8
   9 # This is the worst role evar! Really, this should be a subclass,
  10 # because it overrides a lot of behavior. However, as a subclass it
  11 # won't cooperate with _other_ subclasses.
  12
  13 around _process_options => sub {
  14     my $orig    = shift;
  15     my $class   = shift;
  16     my $name    = shift;
  17     my $options = shift;
  18
  19     confess 'A class attribute cannot be required'
  20         if $options->{required};
  21
  22     return $class->$orig( $name, $options );
  23 };
  24
  25 around attach_to_class => sub {
  26     my $orig = shift;
  27     my $self = shift;
  28     my $meta = shift;
  29
  30     $self->$orig($meta);
  31
  32     $self->_initialize($meta)
  33         unless $self->is_lazy();
  34 };
  35
  36 around detach_from_class => sub {
  37     my $orig = shift;
  38     my $self = shift;
  39     my $meta = shift;
  40
  41     $self->clear_value($meta);
  42
  43     $self->$orig($meta);
  44 };
  45
  46 sub _initialize {
  47     my $self      = shift;
  48     my $metaclass = shift;
  49
  50     if ( $self->has_default() ) {
  51         $self->set_value( undef, $self->default() );
  52     }
  53     elsif ( $self->has_builder() ) {
  54         $self->set_value( undef, $self->_call_builder( $metaclass->name() ) );
  55     }
  56 }
  57
  58 around default => sub {
  59     my $orig = shift;
  60     my $self = shift;
  61
  62     my $default = $self->$orig();
  63
  64     if ( $self->is_default_a_coderef() ) {
  65         return $default->( $self->associated_class() );
  66     }
  67
  68     return $default;
  69 };
  70
  71 around _call_builder => sub {
  72     shift;
  73     my $self  = shift;
  74     my $class = shift;
  75
  76     my $builder = $self->builder();
  77
  78     return $class->$builder()
  79         if $class->can( $self->builder );
  80
  81     confess(  "$class does not support builder method '"
  82             . $self->builder
  83             . "' for attribute '"
  84             . $self->name
  85             . "'" );
  86 };
  87
  88 around set_value => sub {
  89     shift;
  90     my $self = shift;
  91     shift;    # ignoring instance or class name
  92     my $value = shift;
  93
  94     $self->associated_class()
  95         ->set_class_attribute_value( $self->name() => $value );
  96 };
  97
  98 around get_value => sub {
  99     shift;
 100     my $self = shift;
 101
 102     return $self->associated_class()
 103         ->get_class_attribute_value( $self->name() );
 104 };
 105
 106 around has_value => sub {
 107     shift;
 108     my $self = shift;
 109
 110     return $self->associated_class()
 111         ->has_class_attribute_value( $self->name() );
 112 };
 113
 114 around clear_value => sub {
 115     shift;
 116     my $self = shift;
 117
 118     return $self->associated_class()
 119         ->clear_class_attribute_value( $self->name() );
 120 };
 121
 122 around inline_get => sub {
 123     shift;
 124     my $self = shift;
 125
 126     return $self->associated_class()
 127         ->inline_get_class_slot_value( $self->slots() );
 128 };
 129
 130 around inline_set => sub {
 131     shift;
 132     my $self  = shift;
 133     shift;
 134     my $value = shift;
 135
 136     my $meta = $self->associated_class();
 137
 138     my $code
 139         = $meta->inline_set_class_slot_value( $self->slots(), $value ) . ";";
 140     $code
 141         .= $meta->inline_weaken_class_slot_value( $self->slots(), $value )
 142         . "    if ref $value;"
 143         if $self->is_weak_ref();
 144
 145     return $code;
 146 };
 147
 148 around inline_has => sub {
 149     shift;
 150     my $self = shift;
 151
 152     return $self->associated_class()
 153         ->inline_is_class_slot_initialized( $self->slots() );
 154 };
 155
 156 around inline_clear => sub {
 157     shift;
 158     my $self = shift;
 159
 160     return $self->associated_class()
 161         ->inline_deinitialize_class_slot( $self->slots() );
 162 };
 163
 164 1;
 165
 166 # ABSTRACT: A trait for class attributes
 167
 168 __END__
 169
 170 =pod
 171
 172 =head1 DESCRIPTION
 173
 174 This role modifies the behavior of class attributes in various
 175 ways. It really should be a subclass of C<Moose::Meta::Attribute>, but
 176 if it were then it couldn't be combined with other attribute
 177 metaclasses, like C<MooseX::AttributeHelpers>.
 178
 179 There are no new public methods implemented by this role. All it does
 180 is change the behavior of a number of existing methods.
 181
 182 =head1 BUGS
 183
 184 See L<MooseX::ClassAttribute> for details.
 185
 186 =cut