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.82';
  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     Carp::cluck('The initialize_body method has been made private.'
  62         . " The public version is deprecated and will be removed in a future release.\n");
  63     shift->_initialize_body;
  64 }
  65
  66 sub _initialize_body {
  67     my $self = shift;
  68
  69     my $method_name = join "_" => (
  70         '_generate',
  71         $self->accessor_type,
  72         'method',
  73         ($self->is_inline ? 'inline' : ())
  74     );
  75
  76     eval { $self->{'body'} = $self->$method_name() };
  77     die $@ if $@;
  78 }
  79
  80 ## generators
  81
  82 sub generate_accessor_method {
  83     Carp::cluck('The generate_accessor_method method has been made private.'
  84         . " The public version is deprecated and will be removed in a future release.\n");
  85     shift->_generate_accessor_method;
  86 }
  87
  88 sub _generate_accessor_method {
  89     my $attr = (shift)->associated_attribute;
  90     return sub {
  91         $attr->set_value($_[0], $_[1]) if scalar(@_) == 2;
  92         $attr->get_value($_[0]);
  93     };
  94 }
  95
  96 sub generate_reader_method {
  97     Carp::cluck('The generate_reader_method method has been made private.'
  98         . " The public version is deprecated and will be removed in a future release.\n");
  99     shift->_generate_reader_method;
 100 }
 101
 102 sub _generate_reader_method {
 103     my $attr = (shift)->associated_attribute;
 104     return sub {
 105         confess "Cannot assign a value to a read-only accessor" if @_ > 1;
 106         $attr->get_value($_[0]);
 107     };
 108 }
 109
 110 sub generate_writer_method {
 111     Carp::cluck('The generate_writer_method method has been made private.'
 112         . " The public version is deprecated and will be removed in a future release.\n");
 113     shift->_generate_writer_method;
 114 }
 115
 116 sub _generate_writer_method {
 117     my $attr = (shift)->associated_attribute;
 118     return sub {
 119         $attr->set_value($_[0], $_[1]);
 120     };
 121 }
 122
 123 sub generate_predicate_method {
 124     Carp::cluck('The generate_predicate_method method has been made private.'
 125         . " The public version is deprecated and will be removed in a future release.\n");
 126     shift->_generate_predicate_method;
 127 }
 128
 129 sub _generate_predicate_method {
 130     my $attr = (shift)->associated_attribute;
 131     return sub {
 132         $attr->has_value($_[0])
 133     };
 134 }
 135
 136 sub generate_clearer_method {
 137     Carp::cluck('The generate_clearer_method method has been made private.'
 138         . " The public version is deprecated and will be removed in a future release.\n");
 139     shift->_generate_clearer_method;
 140 }
 141
 142 sub _generate_clearer_method {
 143     my $attr = (shift)->associated_attribute;
 144     return sub {
 145         $attr->clear_value($_[0])
 146     };
 147 }
 148
 149 ## Inline methods
 150
 151 sub generate_accessor_method_inline {
 152     Carp::cluck('The generate_accessor_method_inline method has been made private.'
 153         . " The public version is deprecated and will be removed in a future release.\n");
 154     shift->_generate_accessor_method_inline;
 155 }
 156
 157 sub _generate_accessor_method_inline {
 158     my $self          = shift;
 159     my $attr          = $self->associated_attribute;
 160     my $attr_name     = $attr->name;
 161     my $meta_instance = $attr->associated_class->instance_metaclass;
 162
 163     my $code = $self->_eval_closure(
 164         {},
 165         'sub {'
 166         . $meta_instance->inline_set_slot_value('$_[0]', $attr_name, '$_[1]')
 167         . ' if scalar(@_) == 2; '
 168         . $meta_instance->inline_get_slot_value('$_[0]', $attr_name)
 169         . '}'
 170     );
 171     confess "Could not generate inline accessor because : $@" if $@;
 172
 173     return $code;
 174 }
 175
 176 sub generate_reader_method_inline {
 177     Carp::cluck('The generate_reader_method_inline method has been made private.'
 178         . " The public version is deprecated and will be removed in a future release.\n");
 179     shift->_generate_reader_method_inline;
 180 }
 181
 182 sub _generate_reader_method_inline {
 183     my $self          = shift;
 184     my $attr          = $self->associated_attribute;
 185     my $attr_name     = $attr->name;
 186     my $meta_instance = $attr->associated_class->instance_metaclass;
 187
 188      my $code = $self->_eval_closure(
 189          {},
 190         'sub {'
 191         . 'confess "Cannot assign a value to a read-only accessor" if @_ > 1;'
 192         . $meta_instance->inline_get_slot_value('$_[0]', $attr_name)
 193         . '}'
 194     );
 195     confess "Could not generate inline reader because : $@" if $@;
 196
 197     return $code;
 198 }
 199
 200 sub generate_writer_method_inline {
 201     Carp::cluck('The generate_writer_method_inline method has been made private.'
 202         . " The public version is deprecated and will be removed in a future release.\n");
 203     shift->_generate_writer_method_inline;
 204 }
 205
 206 sub _generate_writer_method_inline {
 207     my $self          = shift;
 208     my $attr          = $self->associated_attribute;
 209     my $attr_name     = $attr->name;
 210     my $meta_instance = $attr->associated_class->instance_metaclass;
 211
 212     my $code = $self->_eval_closure(
 213         {},
 214         'sub {'
 215         . $meta_instance->inline_set_slot_value('$_[0]', $attr_name, '$_[1]')
 216         . '}'
 217     );
 218     confess "Could not generate inline writer because : $@" if $@;
 219
 220     return $code;
 221 }
 222
 223 sub generate_predicate_method_inline {
 224     Carp::cluck('The generate_predicate_method_inline method has been made private.'
 225         . " The public version is deprecated and will be removed in a future release.\n");
 226     shift->_generate_predicate_method_inline;
 227 }
 228
 229 sub _generate_predicate_method_inline {
 230     my $self          = shift;
 231     my $attr          = $self->associated_attribute;
 232     my $attr_name     = $attr->name;
 233     my $meta_instance = $attr->associated_class->instance_metaclass;
 234
 235     my $code = $self->_eval_closure(
 236         {},
 237        'sub {'
 238        . $meta_instance->inline_is_slot_initialized('$_[0]', $attr_name)
 239        . '}'
 240     );
 241     confess "Could not generate inline predicate because : $@" if $@;
 242
 243     return $code;
 244 }
 245
 246 sub generate_clearer_method_inline {
 247     Carp::cluck('The generate_clearer_method_inline method has been made private.'
 248         . " The public version is deprecated and will be removed in a future release.\n");
 249     shift->_generate_clearer_method_inline;
 250 }
 251
 252 sub _generate_clearer_method_inline {
 253     my $self          = shift;
 254     my $attr          = $self->associated_attribute;
 255     my $attr_name     = $attr->name;
 256     my $meta_instance = $attr->associated_class->instance_metaclass;
 257
 258     my $code = $self->_eval_closure(
 259         {},
 260         'sub {'
 261         . $meta_instance->inline_deinitialize_slot('$_[0]', $attr_name)
 262         . '}'
 263     );
 264     confess "Could not generate inline clearer because : $@" if $@;
 265
 266     return $code;
 267 }
 268
 269 1;
 270
 271 __END__
 272
 273 =pod
 274
 275 =head1 NAME
 276
 277 Class::MOP::Method::Accessor - Method Meta Object for accessors
 278
 279 =head1 SYNOPSIS
 280
 281     use Class::MOP::Method::Accessor;
 282
 283     my $reader = Class::MOP::Method::Accessor->new(
 284         attribute     => $attribute,
 285         is_inline     => 1,
 286         accessor_type => 'reader',
 287     );
 288
 289     $reader->body->execute($instance); # call the reader method
 290
 291 =head1 DESCRIPTION
 292
 293 This is a subclass of <Class::MOP::Method> which is used by
 294 C<Class::MOP::Attribute> to generate accessor code. It handles
 295 generation of readers, writers, predicates and clearers. For each type
 296 of method, it can either create a subroutine reference, or actually
 297 inline code by generating a string and C<eval>'ing it.
 298
 299 =head1 METHODS
 300
 301 =over 4
 302
 303 =item B<< Class::MOP::Method::Accessor->new(%options) >>
 304
 305 This returns a new C<Class::MOP::Method::Accessor> based on the
 306 C<%options> provided.
 307
 308 =over 4
 309
 310 =item * attribute
 311
 312 This is the C<Class::MOP::Attribute> for which accessors are being
 313 generated. This option is required.
 314
 315 =item * accessor_type
 316
 317 This is a string which should be one of "reader", "writer",
 318 "accessor", "predicate", or "clearer". This is the type of method
 319 being generated. This option is required.
 320
 321 =item * is_inline
 322
 323 This indicates whether or not the accessor should be inlined. This
 324 defaults to false.
 325
 326 =item * name
 327
 328 The method name (without a package name). This is required.
 329
 330 =item * package_name
 331
 332 The package name for the method. This is required.
 333
 334 =back
 335
 336 =item B<< $metamethod->accessor_type >>
 337
 338 Returns the accessor type which was passed to C<new>.
 339
 340 =item B<< $metamethod->is_inline >>
 341
 342 Returns a boolean indicating whether or not the accessor is inlined.
 343
 344 =item B<< $metamethod->associated_attribute >>
 345
 346 This returns the L<Class::MOP::Attribute> object which was passed to
 347 C<new>.
 348
 349 =item B<< $metamethod->body >>
 350
 351 The method itself is I<generated> when the accessor object is
 352 constructed.
 353
 354 =back
 355
 356 =head1 AUTHORS
 357
 358 Stevan Little E<lt>stevan@iinteractive.comE<gt>
 359
 360 =head1 COPYRIGHT AND LICENSE
 361
 362 Copyright 2006-2009 by Infinity Interactive, Inc.
 363
 364 L<http://www.iinteractive.com>
 365
 366 This library is free software; you can redistribute it and/or modify
 367 it under the same terms as Perl itself.
 368
 369 =cut
 370