lib/Class/MOP/Method/Accessor.pm

   1
   2 package Class::MOP::Method::Accessor;
   3
   4 use strict;
   5 use warnings;
   6
   7 use Carp         'confess';
   8 use Scalar::Util 'blessed', 'weaken';
   9
  10 our $VERSION   = '0.78';
  11 $VERSION = eval $VERSION;
  12 our $AUTHORITY = 'cpan:STEVAN';
  13
  14 use base 'Class::MOP::Method::Generated';
  15
  16 sub new {
  17     my $class   = shift;
  18     my %options = @_;
  19
  20     (exists $options{attribute})
  21         || confess "You must supply an attribute to construct with";
  22
  23     (exists $options{accessor_type})
  24         || confess "You must supply an accessor_type to construct with";
  25
  26     (blessed($options{attribute}) && $options{attribute}->isa('Class::MOP::Attribute'))
  27         || confess "You must supply an attribute which is a 'Class::MOP::Attribute' instance";
  28
  29     ($options{package_name} && $options{name})
  30         || confess "You must supply the package_name and name parameters $Class::MOP::Method::UPGRADE_ERROR_TEXT";
  31
  32     my $self = $class->_new(\%options);
  33
  34     # we don't want this creating
  35     # a cycle in the code, if not
  36     # needed
  37     weaken($self->{'attribute'});
  38
  39     $self->initialize_body;
  40
  41     return $self;
  42 }
  43
  44 sub _new {
  45     my $class = shift;
  46     my $options = @_ == 1 ? $_[0] : {@_};
  47
  48     $options->{is_inline} ||= 0;
  49
  50     return bless $options, $class;
  51 }
  52
  53 ## accessors
  54
  55 sub associated_attribute { (shift)->{'attribute'}     }
  56 sub accessor_type        { (shift)->{'accessor_type'} }
  57
  58 ## factory
  59
  60 sub initialize_body {
  61     my $self = shift;
  62
  63     my $method_name = join "_" => (
  64         'generate',
  65         $self->accessor_type,
  66         'method',
  67         ($self->is_inline ? 'inline' : ())
  68     );
  69
  70     eval { $self->{'body'} = $self->$method_name() };
  71     die $@ if $@;
  72 }
  73
  74 ## generators
  75
  76 sub generate_accessor_method {
  77     my $attr = (shift)->associated_attribute;
  78     return sub {
  79         $attr->set_value($_[0], $_[1]) if scalar(@_) == 2;
  80         $attr->get_value($_[0]);
  81     };
  82 }
  83
  84 sub generate_reader_method {
  85     my $attr = (shift)->associated_attribute;
  86     return sub {
  87         confess "Cannot assign a value to a read-only accessor" if @_ > 1;
  88         $attr->get_value($_[0]);
  89     };
  90 }
  91
  92 sub generate_writer_method {
  93     my $attr = (shift)->associated_attribute;
  94     return sub {
  95         $attr->set_value($_[0], $_[1]);
  96     };
  97 }
  98
  99 sub generate_predicate_method {
 100     my $attr = (shift)->associated_attribute;
 101     return sub {
 102         $attr->has_value($_[0])
 103     };
 104 }
 105
 106 sub generate_clearer_method {
 107     my $attr = (shift)->associated_attribute;
 108     return sub {
 109         $attr->clear_value($_[0])
 110     };
 111 }
 112
 113 ## Inline methods
 114
 115
 116 sub generate_accessor_method_inline {
 117     my $self          = shift;
 118     my $attr          = $self->associated_attribute;
 119     my $attr_name     = $attr->name;
 120     my $meta_instance = $attr->associated_class->instance_metaclass;
 121
 122     my $code = $self->_eval_closure(
 123         {},
 124         'sub {'
 125         . $meta_instance->inline_set_slot_value('$_[0]', $attr_name, '$_[1]')
 126         . ' if scalar(@_) == 2; '
 127         . $meta_instance->inline_get_slot_value('$_[0]', $attr_name)
 128         . '}'
 129     );
 130     confess "Could not generate inline accessor because : $@" if $@;
 131
 132     return $code;
 133 }
 134
 135 sub generate_reader_method_inline {
 136     my $self          = shift;
 137     my $attr          = $self->associated_attribute;
 138     my $attr_name     = $attr->name;
 139     my $meta_instance = $attr->associated_class->instance_metaclass;
 140
 141      my $code = $self->_eval_closure(
 142          {},
 143         'sub {'
 144         . 'confess "Cannot assign a value to a read-only accessor" if @_ > 1;'
 145         . $meta_instance->inline_get_slot_value('$_[0]', $attr_name)
 146         . '}'
 147     );
 148     confess "Could not generate inline reader because : $@" if $@;
 149
 150     return $code;
 151 }
 152
 153 sub generate_writer_method_inline {
 154     my $self          = shift;
 155     my $attr          = $self->associated_attribute;
 156     my $attr_name     = $attr->name;
 157     my $meta_instance = $attr->associated_class->instance_metaclass;
 158
 159     my $code = $self->_eval_closure(
 160         {},
 161         'sub {'
 162         . $meta_instance->inline_set_slot_value('$_[0]', $attr_name, '$_[1]')
 163         . '}'
 164     );
 165     confess "Could not generate inline writer because : $@" if $@;
 166
 167     return $code;
 168 }
 169
 170
 171 sub generate_predicate_method_inline {
 172     my $self          = shift;
 173     my $attr          = $self->associated_attribute;
 174     my $attr_name     = $attr->name;
 175     my $meta_instance = $attr->associated_class->instance_metaclass;
 176
 177     my $code = $self->_eval_closure(
 178         {},
 179        'sub {'
 180        . $meta_instance->inline_is_slot_initialized('$_[0]', $attr_name)
 181        . '}'
 182     );
 183     confess "Could not generate inline predicate because : $@" if $@;
 184
 185     return $code;
 186 }
 187
 188 sub generate_clearer_method_inline {
 189     my $self          = shift;
 190     my $attr          = $self->associated_attribute;
 191     my $attr_name     = $attr->name;
 192     my $meta_instance = $attr->associated_class->instance_metaclass;
 193
 194     my $code = $self->_eval_closure(
 195         {},
 196         'sub {'
 197         . $meta_instance->inline_deinitialize_slot('$_[0]', $attr_name)
 198         . '}'
 199     );
 200     confess "Could not generate inline clearer because : $@" if $@;
 201
 202     return $code;
 203 }
 204
 205 1;
 206
 207 __END__
 208
 209 =pod
 210
 211 =head1 NAME
 212
 213 Class::MOP::Method::Accessor - Method Meta Object for accessors
 214
 215 =head1 SYNOPSIS
 216
 217     use Class::MOP::Method::Accessor;
 218
 219     my $reader = Class::MOP::Method::Accessor->new(
 220         attribute     => $attribute,
 221         is_inline     => 1,
 222         accessor_type => 'reader',
 223     );
 224
 225     $reader->body->execute($instance); # call the reader method
 226
 227 =head1 DESCRIPTION
 228
 229 This is a subclass of <Class::MOP::Method> which is used by
 230 C<Class::MOP::Attribute> to generate accessor code. It handles
 231 generation of readers, writers, predicates and clearers. For each type
 232 of method, it can either create a subroutine reference, or actually
 233 inline code by generating a string and C<eval>'ing it.
 234
 235 =head1 METHODS
 236
 237 =over 4
 238
 239 =item B<< Class::MOP::Method::Accessor->new(%options) >>
 240
 241 This returns a new C<Class::MOP::Method::Accessor> based on the
 242 C<%options> provided.
 243
 244 =over 4
 245
 246 =item attribute
 247
 248 This is the C<Class::MOP::Attribute> for which accessors are being
 249 generated. This option is required.
 250
 251 =item accessor_type
 252
 253 This is a string which should be one of "reader", "writer",
 254 "accessor", "predicate", or "clearer". This is the type of method
 255 being generated. This option is required.
 256
 257 =item is_inline
 258
 259 This indicates whether or not the accessor should be inlined. This
 260 default to false.
 261
 262 =back
 263
 264 =item B<< $metamethod->accessor_type >>
 265
 266 Returns the accessor type which was passed to C<new>.
 267
 268 =item B<< $metamethod->is_inline >>
 269
 270 Returns a boolean indicating whether or not the accessor is inlined.
 271
 272 =item B<< $metamethod->associated_attribute >>
 273
 274 This returns the L<Class::MOP::Attribute> object which was passed to
 275 C<new>.
 276
 277 =item B<< $metamethod->body >>
 278
 279 The method itself is I<generated> when the accessor object is
 280 constructed.
 281
 282 =back
 283
 284 =head1 AUTHORS
 285
 286 Stevan Little E<lt>stevan@iinteractive.comE<gt>
 287
 288 =head1 COPYRIGHT AND LICENSE
 289
 290 Copyright 2006-2009 by Infinity Interactive, Inc.
 291
 292 L<http://www.iinteractive.com>
 293
 294 This library is free software; you can redistribute it and/or modify
 295 it under the same terms as Perl itself.
 296
 297 =cut
 298