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