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     my $class_name = $self->associated_class()->name();
  60
  61     if ( $self->has_default() )
  62     {
  63         $self->set_value( $class_name, $self->default() );
  64     }
  65     elsif ( $self->has_builder() )
  66     {
  67         $self->set_value( $class_name, $self->_call_builder() );
  68     }
  69 }
  70
  71 around 'default' => sub
  72 {
  73     my $orig = shift;
  74     my $self = shift;
  75
  76     my $default = $self->$orig();
  77
  78     if ( $self->is_default_a_coderef() )
  79     {
  80         return $default->( $self->associated_class() );
  81     }
  82
  83     return $default;
  84 };
  85
  86 around '_call_builder' => sub
  87 {
  88     shift;
  89     my $self  = shift;
  90     my $class = shift;
  91
  92     my $builder = $self->builder();
  93
  94     return $class->$builder()
  95         if $class->can( $self->builder );
  96
  97     confess(  "$class does not support builder method '"
  98             . $self->builder
  99             . "' for attribute '"
 100             . $self->name
 101             . "'" );
 102 };
 103
 104 around 'set_value' => sub
 105 {
 106     shift;
 107     my $self     = shift;
 108     my $instance = shift;
 109     my $value    = shift;
 110
 111     $self->associated_class()->set_class_attribute_value( $self->name() => $value );
 112 };
 113
 114 around 'get_value' => sub
 115 {
 116     shift;
 117     my $self  = shift;
 118
 119     return $self->associated_class()->get_class_attribute_value( $self->name() );
 120 };
 121
 122 around 'has_value' => sub
 123 {
 124     shift;
 125     my $self  = shift;
 126
 127     return $self->associated_class()->has_class_attribute_value( $self->name() );
 128 };
 129
 130 around 'clear_value' => sub
 131 {
 132     shift;
 133     my $self  = shift;
 134
 135     return $self->associated_class()->clear_class_attribute_value( $self->name() );
 136 };
 137
 138 no Moose::Role;
 139
 140 1;
 141
 142 __END__
 143
 144 =pod
 145
 146 =head1 NAME
 147
 148 MooseX::ClassAttribute::Role::Meta::Attribute - An attribute role for classes with class attributes
 149
 150 =head1 DESCRIPTION
 151
 152 This role modifies the behavior of class attributes in various
 153 ways. It really should be a subclass of C<Moose::Meta::Attribute>, but
 154 if it were then it couldn't be combined with other attribute
 155 metaclasses, like C<MooseX::AttributeHelpers>.
 156
 157 There are no new public methods implemented by this role. All it does
 158 is change the behavior of a number of existing methods.
 159
 160 =head1 AUTHOR
 161
 162 Dave Rolsky, C<< <autarch@urth.org> >>
 163
 164 =head1 BUGS
 165
 166 See L<MooseX::ClassAttribute> for details.
 167
 168 =head1 COPYRIGHT & LICENSE
 169
 170 Copyright 2007-2008 Dave Rolsky, All Rights Reserved.
 171
 172 This program is free software; you can redistribute it and/or modify
 173 it under the same terms as Perl itself.
 174
 175 =cut
 176
 177