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.77';
  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     $self->{'body'} = $self->$method_name();
  71 }
  72
  73 ## generators
  74
  75 sub generate_accessor_method {
  76     my $attr = (shift)->associated_attribute;
  77     return sub {
  78         $attr->set_value($_[0], $_[1]) if scalar(@_) == 2;
  79         $attr->get_value($_[0]);
  80     };
  81 }
  82
  83 sub generate_reader_method {
  84     my $attr = (shift)->associated_attribute;
  85     return sub {
  86         confess "Cannot assign a value to a read-only accessor" if @_ > 1;
  87         $attr->get_value($_[0]);
  88     };
  89 }
  90
  91 sub generate_writer_method {
  92     my $attr = (shift)->associated_attribute;
  93     return sub {
  94         $attr->set_value($_[0], $_[1]);
  95     };
  96 }
  97
  98 sub generate_predicate_method {
  99     my $attr = (shift)->associated_attribute;
 100     return sub {
 101         $attr->has_value($_[0])
 102     };
 103 }
 104
 105 sub generate_clearer_method {
 106     my $attr = (shift)->associated_attribute;
 107     return sub {
 108         $attr->clear_value($_[0])
 109     };
 110 }
 111
 112 ## Inline methods
 113
 114
 115 sub generate_accessor_method_inline {
 116     my $self          = shift;
 117     my $attr          = $self->associated_attribute;
 118     my $attr_name     = $attr->name;
 119     my $meta_instance = $attr->associated_class->instance_metaclass;
 120
 121     return $self->_eval_closure(
 122         {},
 123         'sub {'
 124         . $meta_instance->inline_set_slot_value('$_[0]', $attr_name, '$_[1]')
 125         . ' if scalar(@_) == 2; '
 126         . $meta_instance->inline_get_slot_value('$_[0]', $attr_name)
 127         . '}'
 128     );
 129 }
 130
 131 sub generate_reader_method_inline {
 132     my $self          = shift;
 133     my $attr          = $self->associated_attribute;
 134     my $attr_name     = $attr->name;
 135     my $meta_instance = $attr->associated_class->instance_metaclass;
 136
 137     return $self->_eval_closure(
 138          {},
 139         'sub {'
 140         . 'confess "Cannot assign a value to a read-only accessor" if @_ > 1;'
 141         . $meta_instance->inline_get_slot_value('$_[0]', "'$attr_name'")
 142         . '}'
 143     );
 144 }
 145
 146 sub generate_writer_method_inline {
 147     my $self          = shift;
 148     my $attr          = $self->associated_attribute;
 149     my $attr_name     = $attr->name;
 150     my $meta_instance = $attr->associated_class->instance_metaclass;
 151
 152     return $self->_eval_closure(
 153         {},
 154         'sub {'
 155         . $meta_instance->inline_set_slot_value('$_[0]', "'$attr_name'", '$_[1]')
 156         . '}'
 157     );
 158 }
 159
 160
 161 sub generate_predicate_method_inline {
 162     my $self          = shift;
 163     my $attr          = $self->associated_attribute;
 164     my $attr_name     = $attr->name;
 165     my $meta_instance = $attr->associated_class->instance_metaclass;
 166
 167     return $self->_eval_closure(
 168         {},
 169        'sub {'
 170        . $meta_instance->inline_is_slot_initialized('$_[0]', "'$attr_name'")
 171        . '}'
 172     );
 173 }
 174
 175 sub generate_clearer_method_inline {
 176     my $self          = shift;
 177     my $attr          = $self->associated_attribute;
 178     my $attr_name     = $attr->name;
 179     my $meta_instance = $attr->associated_class->instance_metaclass;
 180
 181     return $self->_eval_closure(
 182         {},
 183         'sub {'
 184         . $meta_instance->inline_deinitialize_slot('$_[0]', "'$attr_name'")
 185         . '}'
 186     );
 187 }
 188
 189 1;
 190
 191 __END__
 192
 193 =pod
 194
 195 =head1 NAME
 196
 197 Class::MOP::Method::Accessor - Method Meta Object for accessors
 198
 199 =head1 SYNOPSIS
 200
 201     use Class::MOP::Method::Accessor;
 202
 203     my $reader = Class::MOP::Method::Accessor->new(
 204         attribute     => $attribute,
 205         is_inline     => 1,
 206         accessor_type => 'reader',
 207     );
 208
 209     $reader->body->execute($instance); # call the reader method
 210
 211 =head1 DESCRIPTION
 212
 213 This is a C<Class::MOP::Method> subclass which is used interally
 214 by C<Class::MOP::Attribute> to generate accessor code. It can
 215 handle generation of readers, writers, predicate and clearer
 216 methods, both as closures and as more optimized inline methods.
 217
 218 =head1 METHODS
 219
 220 =over 4
 221
 222 =item B<new (%options)>
 223
 224 This creates the method based on the criteria in C<%options>,
 225 these options are:
 226
 227 =over 4
 228
 229 =item I<attribute>
 230
 231 This must be an instance of C<Class::MOP::Attribute> which this
 232 accessor is being generated for. This paramter is B<required>.
 233
 234 =item I<accessor_type>
 235
 236 This is a string from the following set; reader, writer, accessor,
 237 predicate or clearer. This is used to determine which type of
 238 method is to be generated.
 239
 240 =item I<is_inline>
 241
 242 This is a boolean to indicate if the method should be generated
 243 as a closure, or as a more optimized inline version.
 244
 245 =back
 246
 247 =item B<accessor_type>
 248
 249 This returns the accessor type which was passed into C<new>.
 250
 251 =item B<is_inline>
 252
 253 This returns the boolean which was passed into C<new>.
 254
 255 =item B<associated_attribute>
 256
 257 This returns the attribute instance which was passed into C<new>.
 258
 259 =item B<initialize_body>
 260
 261 This will actually generate the method based on the specified
 262 criteria passed to the constructor.
 263
 264 =back
 265
 266 =head2 Method Generators
 267
 268 These methods will generate appropriate code references for
 269 the various types of accessors which are supported by
 270 C<Class::MOP::Attribute>. The names pretty much explain it all.
 271
 272 =over 4
 273
 274 =item B<generate_accessor_method>
 275
 276 =item B<generate_accessor_method_inline>
 277
 278 =item B<generate_clearer_method>
 279
 280 =item B<generate_clearer_method_inline>
 281
 282 =item B<generate_predicate_method>
 283
 284 =item B<generate_predicate_method_inline>
 285
 286 =item B<generate_reader_method>
 287
 288 =item B<generate_reader_method_inline>
 289
 290 =item B<generate_writer_method>
 291
 292 =item B<generate_writer_method_inline>
 293
 294 =back
 295
 296 =head1 AUTHORS
 297
 298 Stevan Little E<lt>stevan@iinteractive.comE<gt>
 299
 300 =head1 COPYRIGHT AND LICENSE
 301
 302 Copyright 2006-2008 by Infinity Interactive, Inc.
 303
 304 L<http://www.iinteractive.com>
 305
 306 This library is free software; you can redistribute it and/or modify
 307 it under the same terms as Perl itself.
 308
 309 =cut
 310