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