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