lib/MooseX/ClassAttribute/Trait/Attribute.pm

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