Commit | Line | Data |
c5a105b3 |
1 | package MooseX::Emulate::Class::Accessor::Fast; |
2 | |
e579fc46 |
3 | use Moose::Role; |
c5a105b3 |
4 | |
d52f2e1a |
5 | our $VERSION = '0.00500'; |
c5a105b3 |
6 | |
7 | =head1 NAME |
8 | |
9 | MooseX::Emulate::Class::Accessor::Fast - |
10 | Emulate Class::Accessor::Fast behavior using Moose attributes |
11 | |
12 | =head1 SYNOPSYS |
13 | |
14 | package MyClass; |
144866f7 |
15 | use Moose; |
e579fc46 |
16 | |
17 | with 'MooseX::Emulate::Class::Accessor::Fast'; |
c5a105b3 |
18 | |
c5a105b3 |
19 | |
20 | #fields with readers and writers |
21 | __PACKAGE__->mk_accessors(qw/field1 field2/); |
22 | #fields with readers only |
23 | __PACKAGE__->mk_accessors(qw/field3 field4/); |
24 | #fields with writers only |
25 | __PACKAGE__->mk_accessors(qw/field5 field6/); |
26 | |
27 | |
28 | =head1 DESCRIPTION |
29 | |
30 | This module attempts to emulate the behavior of L<Class::Accessor::Fast> as |
31 | accurately as possible using the Moose attribute system. The public API of |
32 | C<Class::Accessor::Fast> is wholly supported, but the private methods are not. |
33 | If you are only using the public methods (as you should) migration should be a |
e579fc46 |
34 | matter of switching your C<use base> line to a C<with> line. |
c5a105b3 |
35 | |
36 | While I have attempted to emulate the behavior of Class::Accessor::Fast as closely |
37 | as possible bugs may still be lurking in edge-cases. |
38 | |
39 | =head1 BEHAVIOR |
40 | |
41 | Simple documentation is provided here for your convenience, but for more thorough |
42 | documentation please see L<Class::Accessor::Fast> and L<Class::Accessor>. |
43 | |
44 | =head2 A note about introspection |
45 | |
46 | Please note that, at this time, the C<is> flag attribute is not being set. To |
47 | determine the C<reader> and C<writer> methods using introspection in later versions |
48 | of L<Class::MOP> ( > 0.38) please use the C<get_read_method> and C<get_write_method> |
49 | methods in L<Class::MOP::Attribute>. Example |
50 | |
51 | # with Class::MOP <= 0.38 |
52 | my $attr = $self->meta->find_attribute_by_name($field_name); |
53 | my $reader_method = $attr->reader || $attr->accessor; |
54 | my $writer_method = $attr->writer || $attr->accessor; |
55 | |
56 | # with Class::MOP > 0.38 |
57 | my $attr = $self->meta->find_attribute_by_name($field_name); |
58 | my $reader_method = $attr->get_read_method; |
59 | my $writer_method = $attr->get_write_method; |
60 | |
61 | =head1 METHODS |
62 | |
144866f7 |
63 | =head2 BUILD $self %args |
6b8ba79f |
64 | |
144866f7 |
65 | Change the default Moose class building to emulate the behavior of C::A::F and |
6b8ba79f |
66 | store arguments in the instance hashref. |
67 | |
68 | =cut |
69 | |
144866f7 |
70 | sub BUILD { |
71 | my $self = shift; |
6b8ba79f |
72 | my %args; |
73 | if (scalar @_ == 1 && defined $_[0] && ref($_[0]) eq 'HASH') { |
74 | %args = %{$_[0]}; |
7ed9430a |
75 | } elsif( scalar(@_) ) { |
6b8ba79f |
76 | %args = @_; |
77 | } |
6b8ba79f |
78 | my @extra = grep { !exists($self->{$_}) } keys %args; |
79 | @{$self}{@extra} = @args{@extra}; |
80 | return $self; |
144866f7 |
81 | } |
6b8ba79f |
82 | |
c5a105b3 |
83 | =head2 mk_accessors @field_names |
84 | |
85 | Create read-write accessors. An attribute named C<$field_name> will be created. |
86 | The name of the c<reader> and C<writer> methods will be determined by the return |
87 | value of C<accessor_name_for> and C<mutator_name_for>, which by default return the |
88 | name passed unchanged. If the accessor and mutator names are equal the C<accessor> |
89 | attribute will be passes to Moose, otherwise the C<reader> and C<writer> attributes |
90 | will be passed. Please see L<Class::MOP::Attribute> for more information. |
91 | |
92 | =cut |
93 | |
94 | sub mk_accessors{ |
95 | my $self = shift; |
96 | my $meta = $self->meta; |
97 | for my $attr_name (@_){ |
98 | my $reader = $self->accessor_name_for($attr_name); |
99 | my $writer = $self->mutator_name_for( $attr_name); |
30cbeb5e |
100 | |
c5a105b3 |
101 | #dont overwrite existing methods |
30cbeb5e |
102 | if($reader eq $writer){ |
103 | my %opts = ( $self->can($reader) ? () : (accessor => $reader) ); |
104 | my $attr = $meta->add_attribute($attr_name, %opts); |
105 | if($attr_name eq $reader){ |
106 | my $alias = "_${attr_name}_accessor"; |
107 | next if $self->can($alias); |
108 | my @alias_method = $opts{accessor} ? ( $alias => $self->can($reader) ) |
109 | : ( $attr->process_accessors(accessor => $alias, 0 ) ); |
110 | $meta->add_method(@alias_method); |
111 | } |
112 | } else { |
113 | my @opts = ( $self->can($writer) ? () : (writer => $writer) ); |
114 | push(@opts, (reader => $reader)) unless $self->can($reader); |
115 | $meta->add_attribute($attr_name, @opts); |
116 | } |
c5a105b3 |
117 | } |
118 | } |
119 | |
120 | =head2 mk_ro_accessors @field_names |
121 | |
122 | Create read-only accessors. |
123 | |
124 | =cut |
125 | |
126 | sub mk_ro_accessors{ |
127 | my $self = shift; |
128 | my $meta = $self->meta; |
129 | for my $attr_name (@_){ |
130 | my $reader = $self->accessor_name_for($attr_name); |
30cbeb5e |
131 | my @opts = ($self->can($reader) ? () : (reader => $reader) ); |
132 | my $attr = $meta->add_attribute($attr_name, @opts); |
133 | if($reader eq $attr_name && $reader eq $self->mutator_name_for($attr_name)){ |
134 | $meta->add_method("_${attr_name}_accessor" => $attr->get_read_method_ref) |
135 | unless $self->can("_${attr_name}_accessor"); |
136 | } |
c5a105b3 |
137 | } |
138 | } |
139 | |
140 | =head2 mk_ro_accessors @field_names |
141 | |
142 | Create write-only accessors. |
143 | |
144 | =cut |
145 | |
146 | #this is retarded.. but we need it for compatibility or whatever. |
147 | sub mk_wo_accessors{ |
148 | my $self = shift; |
149 | my $meta = $self->meta; |
150 | for my $attr_name (@_){ |
151 | my $writer = $self->mutator_name_for($attr_name); |
30cbeb5e |
152 | my @opts = ($self->can($writer) ? () : (writer => $writer) ); |
153 | my $attr = $meta->add_attribute($attr_name, @opts); |
154 | if($writer eq $attr_name && $writer eq $self->accessor_name_for($attr_name)){ |
155 | $meta->add_method("_${attr_name}_accessor" => $attr->get_write_method_ref) |
156 | unless $self->can("_${attr_name}_accessor"); |
157 | } |
c5a105b3 |
158 | } |
159 | } |
160 | |
161 | =head2 follow_best_practices |
162 | |
163 | Preface readers with 'get_' and writers with 'set_'. |
164 | See original L<Class::Accessor> documentation for more information. |
165 | |
166 | =cut |
167 | |
168 | sub follow_best_practice{ |
169 | my $self = shift; |
170 | my $meta = $self->meta; |
171 | |
172 | $meta->remove_method('mutator_name_for'); |
173 | $meta->remove_method('accessor_name_for'); |
174 | $meta->add_method('mutator_name_for', sub{ return "set_".$_[1] }); |
175 | $meta->add_method('accessor_name_for', sub{ return "get_".$_[1] }); |
176 | } |
177 | |
178 | =head2 mutator_name_for |
179 | |
180 | =head2 accessor_name_for |
181 | |
182 | See original L<Class::Accessor> documentation for more information. |
183 | |
184 | =cut |
185 | |
186 | sub mutator_name_for{ return $_[1] } |
187 | sub accessor_name_for{ return $_[1] } |
188 | |
189 | =head2 set |
190 | |
191 | See original L<Class::Accessor> documentation for more information. |
192 | |
193 | =cut |
194 | |
195 | sub set{ |
196 | my $self = shift; |
197 | my $k = shift; |
198 | confess "Wrong number of arguments received" unless scalar @_; |
199 | |
200 | #my $writer = $self->mutator_name_for( $k ); |
201 | confess "No such attribute '$k'" |
202 | unless ( my $attr = $self->meta->find_attribute_by_name($k) ); |
203 | my $writer = $attr->writer || $attr->accessor; |
204 | $self->$writer(@_ > 1 ? [@_] : @_); |
205 | } |
206 | |
207 | =head2 get |
208 | |
209 | See original L<Class::Accessor> documentation for more information. |
210 | |
211 | =cut |
212 | |
213 | sub get{ |
214 | my $self = shift; |
215 | confess "Wrong number of arguments received" unless scalar @_; |
216 | |
217 | my @values; |
218 | #while( my $attr = $self->meta->find_attribute_by_name( shift(@_) ){ |
219 | for( @_ ){ |
220 | confess "No such attribute '$_'" |
221 | unless ( my $attr = $self->meta->find_attribute_by_name($_) ); |
222 | my $reader = $attr->reader || $attr->accessor; |
223 | @_ > 1 ? push(@values, $self->$reader) : return $self->$reader; |
224 | } |
225 | |
226 | return @values; |
227 | } |
228 | |
8eb9108b |
229 | sub make_accessor { |
230 | my($class, $field) = @_; |
231 | my $meta = $class->meta; |
232 | my $attr = $meta->find_attribute_by_name($field) || $meta->add_attribute($field); |
233 | my $reader = $attr->get_read_method_ref; |
234 | my $writer = $attr->get_write_method_ref; |
235 | return sub { |
236 | my $self = shift; |
e8abb6ef |
237 | return $reader->($self) unless @_; |
238 | return $writer->($self,(@_ > 1 ? [@_] : @_)); |
8eb9108b |
239 | } |
240 | } |
241 | |
242 | |
243 | sub make_ro_accessor { |
244 | my($class, $field) = @_; |
245 | my $meta = $class->meta; |
246 | my $attr = $meta->find_attribute_by_name($field) || $meta->add_attribute($field); |
247 | return $attr->get_read_method_ref; |
248 | } |
249 | |
250 | |
251 | sub make_wo_accessor { |
252 | my($class, $field) = @_; |
253 | my $meta = $class->meta; |
254 | my $attr = $meta->find_attribute_by_name($field) || $meta->add_attribute($field); |
255 | return $attr->get_write_method_ref; |
256 | } |
257 | |
258 | |
c5a105b3 |
259 | 1; |
260 | |
261 | =head2 meta |
262 | |
263 | See L<Moose::Meta::Class>. |
264 | |
265 | =cut |
266 | |
267 | =head1 SEE ALSO |
268 | |
269 | L<Moose>, L<Moose::Meta::Attribute>, L<Class::Accessor>, L<Class::Accessor::Fast>, |
270 | L<Class::MOP::Attribute>, L<MooseX::Adopt::Class::Accessor::Fast> |
271 | |
d82bc8be |
272 | =head1 AUTHORS |
c5a105b3 |
273 | |
7ed9430a |
274 | Guillermo Roditi (groditi) E<lt>groditi@cpan.orgE<gt> |
c5a105b3 |
275 | |
d82bc8be |
276 | With contributions from: |
277 | |
278 | =over 4 |
279 | |
280 | =item Tomas Doran E<lt>bobtfish@bobtfish.netE<gt> |
281 | |
282 | =back |
283 | |
c5a105b3 |
284 | =head1 LICENSE |
285 | |
286 | You may distribute this code under the same terms as Perl itself. |
287 | |
288 | =cut |