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 after attach_to_class => sub {
  26     my $self = shift;
  27     my $meta = shift;
  28
  29     $self->_initialize($meta)
  30         unless $self->is_lazy();
  31 };
  32
  33 before detach_from_class => sub {
  34     my $self = shift;
  35     my $meta = shift;
  36
  37     $self->clear_value($meta);
  38 };
  39
  40 sub _initialize {
  41     my $self      = shift;
  42     my $metaclass = shift;
  43
  44     if ( $self->has_default() ) {
  45         $self->set_value(
  46             undef,
  47             $self->default( $self->associated_class() )
  48         );
  49     }
  50     elsif ( $self->has_builder() ) {
  51         $self->set_value( undef, $self->_call_builder( $metaclass->name() ) );
  52     }
  53 }
  54
  55 around default => sub {
  56     my $orig = shift;
  57     my $self = shift;
  58
  59     my $default = $self->$orig();
  60
  61     if ( $self->is_default_a_coderef() && @_ ) {
  62         return $default->(@_);
  63     }
  64
  65     return $default;
  66 };
  67
  68 around _call_builder => sub {
  69     shift;
  70     my $self  = shift;
  71     my $class = shift;
  72
  73     my $builder = $self->builder();
  74
  75     return $class->$builder()
  76         if $class->can( $self->builder );
  77
  78     confess(  "$class does not support builder method '"
  79             . $self->builder
  80             . "' for attribute '"
  81             . $self->name
  82             . "'" );
  83 };
  84
  85 around set_value => sub {
  86     shift;
  87     my $self = shift;
  88     shift;    # ignoring instance or class name
  89     my $value = shift;
  90
  91     $self->associated_class()
  92         ->set_class_attribute_value( $self->name() => $value );
  93 };
  94
  95 around get_value => sub {
  96     shift;
  97     my $self = shift;
  98
  99     return $self->associated_class()
 100         ->get_class_attribute_value( $self->name() );
 101 };
 102
 103 around has_value => sub {
 104     shift;
 105     my $self = shift;
 106
 107     return $self->associated_class()
 108         ->has_class_attribute_value( $self->name() );
 109 };
 110
 111 around clear_value => sub {
 112     shift;
 113     my $self = shift;
 114
 115     return $self->associated_class()
 116         ->clear_class_attribute_value( $self->name() );
 117 };
 118
 119 if ( $Moose::VERSION < 1.99 ) {
 120     around inline_get => sub {
 121         shift;
 122         my $self = shift;
 123
 124         return $self->associated_class()
 125             ->_inline_get_class_slot_value( $self->slots() );
 126     };
 127
 128     around inline_set => sub {
 129         shift;
 130         my $self = shift;
 131         shift;
 132         my $value = shift;
 133
 134         my $meta = $self->associated_class();
 135
 136         my $code
 137             = $meta->_inline_set_class_slot_value( $self->slots(), $value )
 138             . ";";
 139         $code .= $meta->_inline_weaken_class_slot_value(
 140             $self->slots(),
 141             $value
 142             )
 143             . "    if ref $value;"
 144             if $self->is_weak_ref();
 145
 146         return $code;
 147     };
 148
 149     around inline_has => sub {
 150         shift;
 151         my $self = shift;
 152
 153         return $self->associated_class()
 154             ->_inline_is_class_slot_initialized( $self->slots() );
 155     };
 156
 157     around inline_clear => sub {
 158         shift;
 159         my $self = shift;
 160
 161         return $self->associated_class()
 162             ->_inline_deinitialize_class_slot( $self->slots() );
 163     };
 164 }
 165 else {
 166     around _inline_instance_get => sub {
 167         shift;
 168         my $self = shift;
 169
 170         return $self->associated_class()
 171             ->_inline_get_class_slot_value( $self->slots() );
 172     };
 173
 174     around _inline_instance_set => sub {
 175         shift;
 176         my $self = shift;
 177         shift;
 178         my $value = shift;
 179
 180         return $self->associated_class()
 181             ->_inline_set_class_slot_value( $self->slots(), $value );
 182     };
 183
 184     around _inline_instance_has => sub {
 185         shift;
 186         my $self = shift;
 187
 188         return $self->associated_class()
 189             ->_inline_is_class_slot_initialized( $self->slots() );
 190     };
 191
 192     around _inline_instance_clear => sub {
 193         shift;
 194         my $self = shift;
 195
 196         return $self->associated_class()
 197             ->_inline_deinitialize_class_slot( $self->slots() );
 198     };
 199
 200     around _inline_weaken_value => sub {
 201         shift;
 202         my $self = shift;
 203         shift;
 204         my $value = shift;
 205
 206         return unless $self->is_weak_ref();
 207
 208         return (
 209             $self->associated_class->_inline_weaken_class_slot_value(
 210                 $self->slots(), $value
 211             ),
 212             'if ref ' . $value . ';',
 213         );
 214     };
 215 }
 216
 217 1;
 218
 219 # ABSTRACT: A trait for class attributes
 220
 221 __END__
 222
 223 =pod
 224
 225 =head1 DESCRIPTION
 226
 227 This role modifies the behavior of class attributes in various
 228 ways. It really should be a subclass of C<Moose::Meta::Attribute>, but
 229 if it were then it couldn't be combined with other attribute
 230 metaclasses, like C<MooseX::AttributeHelpers>.
 231
 232 There are no new public methods implemented by this role. All it does
 233 is change the behavior of a number of existing methods.
 234
 235 =head1 BUGS
 236
 237 See L<MooseX::ClassAttribute> for details.
 238
 239 =cut