lib/MooseX/ClassAttribute/Trait/Attribute.pm

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