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 override '_inline_instance_get' => sub {
 123     my $self = shift;
 124
 125     return $self->associated_class()
 126         ->inline_get_class_slot_value( $self->slots() );
 127 };
 128
 129
 130 override _inline_weaken_value => sub {
 131     my $self = shift;
 132     my ($instance, $value) = @_;
 133     return unless $self->is_weak_ref;
 134
 135     my $mi = $self->associated_class->get_meta_instance;
 136     return (
 137         $self->associated_class->inline_weaken_class_slot_value( $self->slots(), $value ),
 138             'if ref ' . $value . ';',
 139     );
 140 };
 141
 142 override '_inline_instance_set' => sub {
 143     my $self  = shift;
 144     shift;
 145     my $value = shift;
 146
 147     my $meta = $self->associated_class();
 148
 149     my $code
 150         = $meta->inline_set_class_slot_value( $self->slots(), $value ) . ";";
 151
 152     return $code;
 153 };
 154
 155 override '_inline_instance_has' => sub {
 156     my $self = shift;
 157
 158     return $self->associated_class()
 159         ->inline_is_class_slot_initialized( $self->slots() );
 160 };
 161
 162 override '_inline_clear_value' => sub {
 163     my $self = shift;
 164
 165     return $self->associated_class()
 166         ->inline_deinitialize_class_slot( $self->slots() );
 167 };
 168
 169 1;
 170
 171 # ABSTRACT: A trait for class attributes
 172
 173 __END__
 174
 175 =pod
 176
 177 =head1 DESCRIPTION
 178
 179 This role modifies the behavior of class attributes in various
 180 ways. It really should be a subclass of C<Moose::Meta::Attribute>, but
 181 if it were then it couldn't be combined with other attribute
 182 metaclasses, like C<MooseX::AttributeHelpers>.
 183
 184 There are no new public methods implemented by this role. All it does
 185 is change the behavior of a number of existing methods.
 186
 187 =head1 BUGS
 188
 189 See L<MooseX::ClassAttribute> for details.
 190
 191 =cut