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