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.02';
  11 our $AUTHORITY = 'cpan:STEVAN';
  12
  13 use base 'Class::MOP::Method';
  14
  15 =pod
  16
  17 So, the idea here is that we have an accessor class
  18 which takes a weak-link to the attribute and can
  19 generate the actual code ref needed. This might allow
  20 for more varied approaches.
  21
  22 And if the attribute type can also declare what
  23 kind of accessor method metaclass it uses, then
  24 this relationship can be handled by delegation.
  25
  26 =cut
  27
  28 sub new {
  29     my $class   = shift;
  30     my %options = @_;
  31
  32     (exists $options{attribute})
  33         || confess "You must supply an attribute to construct with";
  34
  35     (exists $options{accessor_type})
  36         || confess "You must supply an accessor_type to construct with";
  37
  38     (blessed($options{attribute}) && $options{attribute}->isa('Class::MOP::Attribute'))
  39         || confess "You must supply an attribute which is a 'Class::MOP::Attribute' instance";
  40
  41     my $self = bless {
  42         # from our superclass
  43         body          => undef,
  44         # specific to this subclass
  45         attribute     => $options{attribute},
  46         as_inline     => ($options{as_inline} || 0),
  47         accessor_type => $options{accessor_type},
  48     } => $class;
  49
  50     # we don't want this creating
  51     # a cycle in the code, if not
  52     # needed
  53     weaken($self->{attribute});
  54
  55     $self->intialize_body;
  56
  57     return $self;
  58 }
  59
  60 ## accessors
  61
  62 sub associated_attribute { (shift)->{attribute}     }
  63 sub accessor_type        { (shift)->{accessor_type} }
  64 sub as_inline            { (shift)->{as_inline}     }
  65
  66 ## factory
  67
  68 sub intialize_body {
  69     my $self = shift;
  70
  71     my $method_name = join "_" => (
  72         'generate',
  73         $self->accessor_type,
  74         'method',
  75         ($self->as_inline ? 'inline' : ())
  76     );
  77
  78     eval {
  79         $self->{body} = $self->$method_name();
  80     };
  81     die $@ if $@;
  82 }
  83
  84 ## generators
  85
  86 sub generate_accessor_method {
  87     my $attr = (shift)->associated_attribute;
  88     return sub {
  89         $attr->set_value($_[0], $_[1]) if scalar(@_) == 2;
  90         $attr->get_value($_[0]);
  91     };
  92 }
  93
  94 sub generate_reader_method {
  95     my $attr = (shift)->associated_attribute;
  96     return sub {
  97         confess "Cannot assign a value to a read-only accessor" if @_ > 1;
  98         $attr->get_value($_[0]);
  99     };
 100 }
 101
 102 sub generate_writer_method {
 103     my $attr = (shift)->associated_attribute;
 104     return sub {
 105         $attr->set_value($_[0], $_[1]);
 106     };
 107 }
 108
 109 sub generate_predicate_method {
 110     my $attr      = (shift)->associated_attribute;
 111     my $attr_name = $attr->name;
 112     return sub {
 113         defined Class::MOP::Class->initialize(Scalar::Util::blessed($_[0]))
 114                                  ->get_meta_instance
 115                                  ->get_slot_value($_[0], $attr_name) ? 1 : 0;
 116     };
 117 }
 118
 119 sub generate_clearer_method {
 120     my $attr      = (shift)->associated_attribute;
 121     my $attr_name = $attr->name;
 122     return sub {
 123         Class::MOP::Class->initialize(Scalar::Util::blessed($_[0]))
 124                          ->get_meta_instance
 125                          ->deinitialize_slot($_[0], $attr_name);
 126     };
 127 }
 128
 129 ## Inline methods
 130
 131
 132 sub generate_accessor_method_inline {
 133     my $attr          = (shift)->associated_attribute;
 134     my $attr_name     = $attr->name;
 135     my $meta_instance = $attr->associated_class->instance_metaclass;
 136
 137     my $code = eval 'sub {'
 138         . $meta_instance->inline_set_slot_value('$_[0]', "'$attr_name'", '$_[1]')  . ' if scalar(@_) == 2; '
 139         . $meta_instance->inline_get_slot_value('$_[0]', "'$attr_name'")
 140     . '}';
 141     confess "Could not generate inline accessor because : $@" if $@;
 142
 143     return $code;
 144 }
 145
 146 sub generate_reader_method_inline {
 147     my $attr          = (shift)->associated_attribute;
 148     my $attr_name     = $attr->name;
 149     my $meta_instance = $attr->associated_class->instance_metaclass;
 150
 151     my $code = eval 'sub {'
 152         . 'confess "Cannot assign a value to a read-only accessor" if @_ > 1;'
 153         . $meta_instance->inline_get_slot_value('$_[0]', "'$attr_name'")
 154     . '}';
 155     confess "Could not generate inline accessor because : $@" if $@;
 156
 157     return $code;
 158 }
 159
 160 sub generate_writer_method_inline {
 161     my $attr          = (shift)->associated_attribute;
 162     my $attr_name     = $attr->name;
 163     my $meta_instance = $attr->associated_class->instance_metaclass;
 164
 165     my $code = eval 'sub {'
 166         . $meta_instance->inline_set_slot_value('$_[0]', "'$attr_name'", '$_[1]')
 167     . '}';
 168     confess "Could not generate inline accessor because : $@" if $@;
 169
 170     return $code;
 171 }
 172
 173
 174 sub generate_predicate_method_inline {
 175     my $attr          = (shift)->associated_attribute;
 176     my $attr_name     = $attr->name;
 177     my $meta_instance = $attr->associated_class->instance_metaclass;
 178
 179     my $code = eval 'sub {'
 180         . 'defined ' . $meta_instance->inline_get_slot_value('$_[0]', "'$attr_name'") . ' ? 1 : 0'
 181     . '}';
 182     confess "Could not generate inline predicate because : $@" if $@;
 183
 184     return $code;
 185 }
 186
 187 sub generate_clearer_method_inline {
 188     my $attr          = (shift)->associated_attribute;
 189     my $attr_name     = $attr->name;
 190     my $meta_instance = $attr->associated_class->instance_metaclass;
 191
 192     my $code = eval 'sub {'
 193         . $meta_instance->inline_deinitialize_slot('$_[0]', "'$attr_name'")
 194     . '}';
 195     confess "Could not generate inline clearer because : $@" if $@;
 196
 197     return $code;
 198 }
 199
 200 1;
 201
 202 __END__
 203
 204 =pod
 205
 206 =head1 NAME
 207
 208 Class::MOP::Method::Accessor - Method Meta Object for accessors
 209
 210 =head1 SYNOPSIS
 211
 212   # ... more to come later maybe
 213
 214 =head1 DESCRIPTION
 215
 216 =head1 METHODS
 217
 218 =over 4
 219
 220 =item B<new>
 221
 222 =item B<intialize_body>
 223
 224 =item B<accessor_type>
 225
 226 =item B<as_inline>
 227
 228 =item B<associated_attribute>
 229
 230 =item B<generate_accessor_method>
 231
 232 =item B<generate_accessor_method_inline>
 233
 234 =item B<generate_clearer_method>
 235
 236 =item B<generate_clearer_method_inline>
 237
 238 =item B<generate_predicate_method>
 239
 240 =item B<generate_predicate_method_inline>
 241
 242 =item B<generate_reader_method>
 243
 244 =item B<generate_reader_method_inline>
 245
 246 =item B<generate_writer_method>
 247
 248 =item B<generate_writer_method_inline>
 249
 250 =back
 251
 252 =head1 AUTHORS
 253
 254 Stevan Little E<lt>stevan@iinteractive.comE<gt>
 255
 256 Yuval Kogman E<lt>nothingmuch@woobling.comE<gt>
 257
 258 =head1 COPYRIGHT AND LICENSE
 259
 260 Copyright 2006 by Infinity Interactive, Inc.
 261
 262 L<http://www.iinteractive.com>
 263
 264 This library is free software; you can redistribute it and/or modify
 265 it under the same terms as Perl itself.
 266
 267 =cut
 268