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