lib/MooseX/ClassAttribute/Role/Meta/Attribute.pm

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