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