2 package Class::MOP::Method::Accessor;
8 use Scalar::Util 'blessed', 'weaken';
10 our $VERSION = '0.92';
11 $VERSION = eval $VERSION;
12 our $AUTHORITY = 'cpan:STEVAN';
14 use base 'Class::MOP::Method::Generated';
20 (exists $options{attribute})
21 || confess "You must supply an attribute to construct with";
23 (exists $options{accessor_type})
24 || confess "You must supply an accessor_type to construct with";
26 (blessed($options{attribute}) && $options{attribute}->isa('Class::MOP::Attribute'))
27 || confess "You must supply an attribute which is a 'Class::MOP::Attribute' instance";
29 ($options{package_name} && $options{name})
30 || confess "You must supply the package_name and name parameters $Class::MOP::Method::UPGRADE_ERROR_TEXT";
32 my $self = $class->_new(\%options);
34 # we don't want this creating
35 # a cycle in the code, if not
37 weaken($self->{'attribute'});
38 weaken($self->{'associated_metaclass'});
40 $self->_initialize_body;
48 return Class::MOP::Class->initialize($class)->new_object(@_)
49 if $class ne __PACKAGE__;
51 my $params = @_ == 1 ? $_[0] : {@_};
54 # inherited from Class::MOP::Method
55 body => $params->{body},
56 associated_metaclass => $params->{associated_metaclass},
57 package_name => $params->{package_name},
58 name => $params->{name},
59 original_method => $params->{original_method},
61 # inherit from Class::MOP::Generated
62 is_inline => $params->{is_inline},
63 definition_context => $params->{definition_context},
65 # defined in this class
66 attribute => $params->{attribute},
67 accessor_type => $params->{accessor_type},
74 sub _initialize_body {
77 my $method_name = join "_" => (
83 $self->{'body'} = $self->$method_name();
89 sub _generate_accessor_method {
92 if(my $xs = $self->associated_metaclass->instance_metaclass->can_xs()){
93 return $self->_generate_accessor_method_xs($xs);
97 return $self->_generate_accessor_method_inline();
100 return $self->_generate_accessor_method_basic();
103 sub _generate_reader_method {
106 if(my $xs = $self->associated_metaclass->instance_metaclass->can_xs()){
107 return $self->_generate_reader_method_xs($xs);
110 if($self->is_inline){
111 return $self->_generate_reader_method_inline();
114 return $self->_generate_reader_method_basic();
117 sub _generate_writer_method {
120 if(my $xs = $self->associated_metaclass->instance_metaclass->can_xs()){
121 return $self->_generate_writer_method_xs($xs);
124 if($self->is_inline){
125 return $self->_generate_writer_method_inline();
128 return $self->_generate_writer_method_basic();
131 sub _generate_clearer_method {
134 if(my $xs = $self->associated_metaclass->instance_metaclass->can_xs()){
135 return $self->_generate_clearer_method_xs($xs);
138 if($self->is_inline){
139 return $self->_generate_clearer_method_inline();
142 return $self->_generate_clearer_method_basic();
145 sub _generate_predicate_method {
148 if(my $xs = $self->associated_metaclass->instance_metaclass->can_xs()){
149 return $self->_generate_predicate_method_xs($xs);
152 if($self->is_inline){
153 return $self->_generate_predicate_method_inline();
156 return $self->_generate_predicate_method_basic();
162 sub generate_accessor_method {
163 Carp::cluck('The generate_accessor_method method has been made private.'
164 . " The public version is deprecated and will be removed in a future release.\n");
165 shift->_generate_accessor_method_basic;
168 sub _generate_accessor_method_basic {
169 my $attr = (shift)->associated_attribute;
171 $attr->set_value($_[0], $_[1]) if scalar(@_) == 2;
172 $attr->get_value($_[0]);
176 sub generate_reader_method {
177 Carp::cluck('The generate_reader_method method has been made private.'
178 . " The public version is deprecated and will be removed in a future release.\n");
179 shift->_generate_reader_method_basic;
182 sub _generate_reader_method_basic {
183 my $attr = (shift)->associated_attribute;
185 confess "Cannot assign a value to a read-only accessor" if @_ > 1;
186 $attr->get_value($_[0]);
190 sub generate_writer_method {
191 Carp::cluck('The generate_writer_method method has been made private.'
192 . " The public version is deprecated and will be removed in a future release.\n");
193 shift->_generate_writer_method_basic;
196 sub _generate_writer_method_basic {
197 my $attr = (shift)->associated_attribute;
199 $attr->set_value($_[0], $_[1]);
203 sub generate_predicate_method {
204 Carp::cluck('The generate_predicate_method method has been made private.'
205 . " The public version is deprecated and will be removed in a future release.\n");
206 shift->_generate_predicate_method_basic;
209 sub _generate_predicate_method_basic {
210 my $attr = (shift)->associated_attribute;
212 $attr->has_value($_[0])
216 sub generate_clearer_method {
217 Carp::cluck('The generate_clearer_method method has been made private.'
218 . " The public version is deprecated and will be removed in a future release.\n");
219 shift->_generate_clearer_method_basic;
222 sub _generate_clearer_method_basic {
223 my $attr = (shift)->associated_attribute;
225 $attr->clear_value($_[0])
231 sub _generate_accessor_method_inline {
233 my $attr = $self->associated_attribute;
234 my $attr_name = $attr->name;
235 my $meta_instance = $attr->associated_class->instance_metaclass;
237 my ( $code, $e ) = $self->_eval_closure(
240 . $meta_instance->inline_set_slot_value('$_[0]', $attr_name, '$_[1]')
241 . ' if scalar(@_) == 2; '
242 . $meta_instance->inline_get_slot_value('$_[0]', $attr_name)
245 confess "Could not generate inline accessor because : $e" if $e;
250 sub _generate_reader_method_inline {
252 my $attr = $self->associated_attribute;
253 my $attr_name = $attr->name;
254 my $meta_instance = $attr->associated_class->instance_metaclass;
256 my ( $code, $e ) = $self->_eval_closure(
259 . 'confess "Cannot assign a value to a read-only accessor" if @_ > 1;'
260 . $meta_instance->inline_get_slot_value('$_[0]', $attr_name)
263 confess "Could not generate inline reader because : $e" if $e;
268 sub _generate_writer_method_inline {
270 my $attr = $self->associated_attribute;
271 my $attr_name = $attr->name;
272 my $meta_instance = $attr->associated_class->instance_metaclass;
274 my ( $code, $e ) = $self->_eval_closure(
277 . $meta_instance->inline_set_slot_value('$_[0]', $attr_name, '$_[1]')
280 confess "Could not generate inline writer because : $e" if $e;
285 sub _generate_predicate_method_inline {
287 my $attr = $self->associated_attribute;
288 my $attr_name = $attr->name;
289 my $meta_instance = $attr->associated_class->instance_metaclass;
291 my ( $code, $e ) = $self->_eval_closure(
294 . $meta_instance->inline_is_slot_initialized('$_[0]', $attr_name)
297 confess "Could not generate inline predicate because : $e" if $e;
302 sub _generate_clearer_method_inline {
304 my $attr = $self->associated_attribute;
305 my $attr_name = $attr->name;
306 my $meta_instance = $attr->associated_class->instance_metaclass;
308 my ( $code, $e ) = $self->_eval_closure(
311 . $meta_instance->inline_deinitialize_slot('$_[0]', $attr_name)
314 confess "Could not generate inline clearer because : $e" if $e;
327 Class::MOP::Method::Accessor - Method Meta Object for accessors
331 use Class::MOP::Method::Accessor;
333 my $reader = Class::MOP::Method::Accessor->new(
334 attribute => $attribute,
336 accessor_type => 'reader',
339 $reader->body->execute($instance); # call the reader method
343 This is a subclass of <Class::MOP::Method> which is used by
344 C<Class::MOP::Attribute> to generate accessor code. It handles
345 generation of readers, writers, predicates and clearers. For each type
346 of method, it can either create a subroutine reference, or actually
347 inline code by generating a string and C<eval>'ing it.
353 =item B<< Class::MOP::Method::Accessor->new(%options) >>
355 This returns a new C<Class::MOP::Method::Accessor> based on the
356 C<%options> provided.
362 This is the C<Class::MOP::Attribute> for which accessors are being
363 generated. This option is required.
365 =item * accessor_type
367 This is a string which should be one of "reader", "writer",
368 "accessor", "predicate", or "clearer". This is the type of method
369 being generated. This option is required.
373 This indicates whether or not the accessor should be inlined. This
378 The method name (without a package name). This is required.
382 The package name for the method. This is required.
386 =item B<< $metamethod->accessor_type >>
388 Returns the accessor type which was passed to C<new>.
390 =item B<< $metamethod->is_inline >>
392 Returns a boolean indicating whether or not the accessor is inlined.
394 =item B<< $metamethod->associated_attribute >>
396 This returns the L<Class::MOP::Attribute> object which was passed to
399 =item B<< $metamethod->body >>
401 The method itself is I<generated> when the accessor object is
408 Stevan Little E<lt>stevan@iinteractive.comE<gt>
410 =head1 COPYRIGHT AND LICENSE
412 Copyright 2006-2009 by Infinity Interactive, Inc.
414 L<http://www.iinteractive.com>
416 This library is free software; you can redistribute it and/or modify
417 it under the same terms as Perl itself.