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