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