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