Commit | Line | Data |
c5a105b3 |
1 | package MooseX::Emulate::Class::Accessor::Fast; |
2 | |
3 | use Moose; |
4 | |
5 | our $VERSION = 0.0001; |
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; |
15 | |
16 | use base 'MooseX::Emulate::Class::Accessor::Fast'; |
17 | #or |
18 | use Moose; |
19 | extends 'MooseX::Emulate::Class::Accessor::Fast'; |
20 | |
21 | #fields with readers and writers |
22 | __PACKAGE__->mk_accessors(qw/field1 field2/); |
23 | #fields with readers only |
24 | __PACKAGE__->mk_accessors(qw/field3 field4/); |
25 | #fields with writers only |
26 | __PACKAGE__->mk_accessors(qw/field5 field6/); |
27 | |
28 | |
29 | =head1 DESCRIPTION |
30 | |
31 | This module attempts to emulate the behavior of L<Class::Accessor::Fast> as |
32 | accurately as possible using the Moose attribute system. The public API of |
33 | C<Class::Accessor::Fast> is wholly supported, but the private methods are not. |
34 | If you are only using the public methods (as you should) migration should be a |
35 | matter of switching your C<use base> line. |
36 | |
37 | While I have attempted to emulate the behavior of Class::Accessor::Fast as closely |
38 | as possible bugs may still be lurking in edge-cases. |
39 | |
40 | =head1 BEHAVIOR |
41 | |
42 | Simple documentation is provided here for your convenience, but for more thorough |
43 | documentation please see L<Class::Accessor::Fast> and L<Class::Accessor>. |
44 | |
45 | =head2 A note about introspection |
46 | |
47 | Please note that, at this time, the C<is> flag attribute is not being set. To |
48 | determine the C<reader> and C<writer> methods using introspection in later versions |
49 | of L<Class::MOP> ( > 0.38) please use the C<get_read_method> and C<get_write_method> |
50 | methods in L<Class::MOP::Attribute>. Example |
51 | |
52 | # with Class::MOP <= 0.38 |
53 | my $attr = $self->meta->find_attribute_by_name($field_name); |
54 | my $reader_method = $attr->reader || $attr->accessor; |
55 | my $writer_method = $attr->writer || $attr->accessor; |
56 | |
57 | # with Class::MOP > 0.38 |
58 | my $attr = $self->meta->find_attribute_by_name($field_name); |
59 | my $reader_method = $attr->get_read_method; |
60 | my $writer_method = $attr->get_write_method; |
61 | |
62 | =head1 METHODS |
63 | |
64 | =head2 mk_accessors @field_names |
65 | |
66 | Create read-write accessors. An attribute named C<$field_name> will be created. |
67 | The name of the c<reader> and C<writer> methods will be determined by the return |
68 | value of C<accessor_name_for> and C<mutator_name_for>, which by default return the |
69 | name passed unchanged. If the accessor and mutator names are equal the C<accessor> |
70 | attribute will be passes to Moose, otherwise the C<reader> and C<writer> attributes |
71 | will be passed. Please see L<Class::MOP::Attribute> for more information. |
72 | |
73 | =cut |
74 | |
75 | sub mk_accessors{ |
76 | my $self = shift; |
77 | my $meta = $self->meta; |
78 | for my $attr_name (@_){ |
79 | my $reader = $self->accessor_name_for($attr_name); |
80 | my $writer = $self->mutator_name_for( $attr_name); |
81 | #dont overwrite existing methods |
82 | my @opts = $reader eq $writer ? |
83 | ( $self->can($reader) ? () : (accessor => $reader) ) : |
84 | ( |
85 | ( $self->can($reader) ? () : (reader => $reader) ), |
86 | ( $self->can($writer) ? () : (writer => $writer) ), |
87 | ); |
88 | $meta->add_attribute($attr_name, @opts); |
89 | |
90 | $meta->add_method("_${attr_name}_accessor", $self->can($reader) ) |
91 | if($reader eq $attr_name && !$self->can("_${attr_name}_accessor") ); |
92 | } |
93 | } |
94 | |
95 | =head2 mk_ro_accessors @field_names |
96 | |
97 | Create read-only accessors. |
98 | |
99 | =cut |
100 | |
101 | sub mk_ro_accessors{ |
102 | my $self = shift; |
103 | my $meta = $self->meta; |
104 | for my $attr_name (@_){ |
105 | my $reader = $self->accessor_name_for($attr_name); |
106 | $meta->add_attribute($attr_name, |
107 | $self->can($reader) ? () : (reader => $reader) ); |
108 | $meta->add_method("_${attr_name}_accessor", $meta->find_method_by_name($reader)) |
109 | if($reader eq $attr_name && !$self->can("_${attr_name}_accessor") ); |
110 | } |
111 | } |
112 | |
113 | =head2 mk_ro_accessors @field_names |
114 | |
115 | Create write-only accessors. |
116 | |
117 | =cut |
118 | |
119 | #this is retarded.. but we need it for compatibility or whatever. |
120 | sub mk_wo_accessors{ |
121 | my $self = shift; |
122 | my $meta = $self->meta; |
123 | for my $attr_name (@_){ |
124 | my $writer = $self->mutator_name_for($attr_name); |
125 | $meta->add_attribute($attr_name, $self->can($writer) ? () : (writer => $writer) ); |
126 | $meta->add_method("_${attr_name}_accessor", $meta->find_method_by_name($writer)) |
127 | if($writer eq $attr_name && !$self->can("_${attr_name}_accessor") ); |
128 | } |
129 | } |
130 | |
131 | =head2 follow_best_practices |
132 | |
133 | Preface readers with 'get_' and writers with 'set_'. |
134 | See original L<Class::Accessor> documentation for more information. |
135 | |
136 | =cut |
137 | |
138 | sub follow_best_practice{ |
139 | my $self = shift; |
140 | my $meta = $self->meta; |
141 | |
142 | $meta->remove_method('mutator_name_for'); |
143 | $meta->remove_method('accessor_name_for'); |
144 | $meta->add_method('mutator_name_for', sub{ return "set_".$_[1] }); |
145 | $meta->add_method('accessor_name_for', sub{ return "get_".$_[1] }); |
146 | } |
147 | |
148 | =head2 mutator_name_for |
149 | |
150 | =head2 accessor_name_for |
151 | |
152 | See original L<Class::Accessor> documentation for more information. |
153 | |
154 | =cut |
155 | |
156 | sub mutator_name_for{ return $_[1] } |
157 | sub accessor_name_for{ return $_[1] } |
158 | |
159 | =head2 set |
160 | |
161 | See original L<Class::Accessor> documentation for more information. |
162 | |
163 | =cut |
164 | |
165 | sub set{ |
166 | my $self = shift; |
167 | my $k = shift; |
168 | confess "Wrong number of arguments received" unless scalar @_; |
169 | |
170 | #my $writer = $self->mutator_name_for( $k ); |
171 | confess "No such attribute '$k'" |
172 | unless ( my $attr = $self->meta->find_attribute_by_name($k) ); |
173 | my $writer = $attr->writer || $attr->accessor; |
174 | $self->$writer(@_ > 1 ? [@_] : @_); |
175 | } |
176 | |
177 | =head2 get |
178 | |
179 | See original L<Class::Accessor> documentation for more information. |
180 | |
181 | =cut |
182 | |
183 | sub get{ |
184 | my $self = shift; |
185 | confess "Wrong number of arguments received" unless scalar @_; |
186 | |
187 | my @values; |
188 | #while( my $attr = $self->meta->find_attribute_by_name( shift(@_) ){ |
189 | for( @_ ){ |
190 | confess "No such attribute '$_'" |
191 | unless ( my $attr = $self->meta->find_attribute_by_name($_) ); |
192 | my $reader = $attr->reader || $attr->accessor; |
193 | @_ > 1 ? push(@values, $self->$reader) : return $self->$reader; |
194 | } |
195 | |
196 | return @values; |
197 | } |
198 | |
199 | 1; |
200 | |
201 | =head2 meta |
202 | |
203 | See L<Moose::Meta::Class>. |
204 | |
205 | =cut |
206 | |
207 | =head1 SEE ALSO |
208 | |
209 | L<Moose>, L<Moose::Meta::Attribute>, L<Class::Accessor>, L<Class::Accessor::Fast>, |
210 | L<Class::MOP::Attribute>, L<MooseX::Adopt::Class::Accessor::Fast> |
211 | |
212 | =head1 AUTHOR |
213 | |
214 | Guillermo Roditi (groditi) <groditi@cpan.org> |
215 | |
216 | =head1 LICENSE |
217 | |
218 | You may distribute this code under the same terms as Perl itself. |
219 | |
220 | =cut |