From: Scott McWhirter <scott+github@konobi.co.uk>
Date: Fri, 26 Jun 2009 04:06:45 +0000 (+0100)
Subject: Add initial split out Reader accessor method
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=32b01180e289b3e23f7cc7d8ab1a4476a4087f93;p=gitmo%2FClass-MOP.git

Add initial split out Reader accessor method
---

diff --git a/lib/Class/MOP.pm b/lib/Class/MOP.pm
index 5ac9773..859fa4f 100644
--- a/lib/Class/MOP.pm
+++ b/lib/Class/MOP.pm
@@ -595,17 +595,17 @@ Class::MOP::Method::Inlined->meta->add_attribute(
 ## --------------------------------------------------------
 ## Class::MOP::Method::Accessor
 
-Class::MOP::Method::Accessor->meta->add_attribute(
+Class::MOP::Method::Attribute->meta->add_attribute(
     Class::MOP::Attribute->new('attribute' => (
         reader   => {
-            'associated_attribute' => \&Class::MOP::Method::Accessor::associated_attribute
+            'associated_attribute' => \&Class::MOP::Method::Attribute::associated_attribute
         },
     ))
 );
 
-Class::MOP::Method::Accessor->meta->add_attribute(
+Class::MOP::Method::Attribute->meta->add_attribute(
     Class::MOP::Attribute->new('accessor_type' => (
-        reader   => { 'accessor_type' => \&Class::MOP::Method::Accessor::accessor_type },
+        reader   => { 'accessor_type' => \&Class::MOP::Method::Attribute::accessor_type },
     ))
 );
 
@@ -704,6 +704,7 @@ $_->meta->make_immutable(
     Class::MOP::Method::Inlined
 
     Class::MOP::Method::Accessor
+    Class::MOP::Method::Attribute
     Class::MOP::Method::Constructor
     Class::MOP::Method::Wrapped
 /;
diff --git a/lib/Class/MOP/Attribute.pm b/lib/Class/MOP/Attribute.pm
index d8806d1..1865a51 100644
--- a/lib/Class/MOP/Attribute.pm
+++ b/lib/Class/MOP/Attribute.pm
@@ -5,6 +5,8 @@ use strict;
 use warnings;
 
 use Class::MOP::Method::Accessor;
+use Class::MOP::Method::Reader;
+use Class::MOP::Method::Writer;
 
 use Carp         'confess';
 use Scalar::Util 'blessed', 'weaken';
@@ -376,6 +378,12 @@ sub clear_value {
 ## load em up ...
 
 sub accessor_metaclass { 'Class::MOP::Method::Accessor' }
+sub method_metaclasses {
+    {
+        reader => 'Class::MOP::Method::Reader',
+        #writer => 'Class::MOP::Method::Writer',
+    }
+}
 
 sub _process_accessors {
     my ($self, $type, $accessor, $generate_as_inline_methods) = @_;
@@ -412,7 +420,9 @@ sub _process_accessors {
                 $method_ctx->{description} = $desc;
             }
 
-            $method = $self->accessor_metaclass->new(
+            my $method_metaclass = $self->method_metaclasses->{$type} || $self->accessor_metaclass;
+
+            $method = $method_metaclass->new(
                 attribute     => $self,
                 is_inline     => $inline_me,
                 accessor_type => $type,
@@ -463,7 +473,7 @@ sub install_accessors {
         }
         my $method = $class->get_method($accessor);
         $class->remove_method($accessor)
-            if (ref($method) && $method->isa('Class::MOP::Method::Accessor'));
+            if (ref($method) && $method->isa('Class::MOP::Method::Attribute'));
     };
 
     sub remove_accessors {
diff --git a/lib/Class/MOP/Method/Accessor.pm b/lib/Class/MOP/Method/Accessor.pm
index 6dfd22c..ad5c90a 100644
--- a/lib/Class/MOP/Method/Accessor.pm
+++ b/lib/Class/MOP/Method/Accessor.pm
@@ -11,66 +11,7 @@ our $VERSION   = '0.94';
 $VERSION = eval $VERSION;
 our $AUTHORITY = 'cpan:STEVAN';
 
-use base 'Class::MOP::Method::Generated';
-
-sub new {
-    my $class   = shift;
-    my %options = @_;
-
-    (exists $options{attribute})
-        || confess "You must supply an attribute to construct with";
-
-    (exists $options{accessor_type})
-        || confess "You must supply an accessor_type to construct with";
-
-    (blessed($options{attribute}) && $options{attribute}->isa('Class::MOP::Attribute'))
-        || confess "You must supply an attribute which is a 'Class::MOP::Attribute' instance";
-
-    ($options{package_name} && $options{name})
-        || confess "You must supply the package_name and name parameters $Class::MOP::Method::UPGRADE_ERROR_TEXT";
-
-    my $self = $class->_new(\%options);
-
-    # we don't want this creating
-    # a cycle in the code, if not
-    # needed
-    weaken($self->{'attribute'});
-
-    return $self;
-}
-
-sub _new {
-    my $class = shift;
-
-    return Class::MOP::Class->initialize($class)->new_object(@_)
-        if $class ne __PACKAGE__;
-
-    my $params = @_ == 1 ? $_[0] : {@_};
-
-    return bless {
-        # inherited from Class::MOP::Method
-        body                 => $params->{body},
-        associated_metaclass => $params->{associated_metaclass},
-        package_name         => $params->{package_name},
-        name                 => $params->{name},
-        original_method      => $params->{original_method},
-
-        # inherit from Class::MOP::Generated
-        is_inline            => $params->{is_inline} || 0,
-        definition_context   => $params->{definition_context},
-
-        # defined in this class
-        attribute            => $params->{attribute},
-        accessor_type        => $params->{accessor_type},
-    } => $class;
-}
-
-## accessors
-
-sub associated_attribute { (shift)->{'attribute'}     }
-sub accessor_type        { (shift)->{'accessor_type'} }
-
-## factory
+use base 'Class::MOP::Method::Attribute';
 
 sub _initialize_body {
     my $self = shift;
@@ -217,6 +158,7 @@ sub _generate_clearer_method_inline {
 
 1;
 
+# XXX - UPDATE DOCS
 __END__
 
 =pod
diff --git a/lib/Class/MOP/Method/Attribute.pm b/lib/Class/MOP/Method/Attribute.pm
new file mode 100644
index 0000000..35c6ad1
--- /dev/null
+++ b/lib/Class/MOP/Method/Attribute.pm
@@ -0,0 +1,163 @@
+
+package Class::MOP::Method::Attribute;
+
+use strict;
+use warnings;
+
+use Carp         'confess';
+use Scalar::Util 'blessed', 'weaken';
+
+our $VERSION   = '0.88';
+$VERSION = eval $VERSION;
+our $AUTHORITY = 'cpan:STEVAN';
+
+use base 'Class::MOP::Method::Generated';
+
+sub new {
+    my $class   = shift;
+    my %options = @_;
+
+    (exists $options{attribute})
+        || confess "You must supply an attribute to construct with";
+
+    (blessed($options{attribute}) && $options{attribute}->isa('Class::MOP::Attribute'))
+        || confess "You must supply an attribute which is a 'Class::MOP::Attribute' instance";
+
+    ($options{package_name} && $options{name})
+        || confess "You must supply the package_name and name parameters $Class::MOP::Method::UPGRADE_ERROR_TEXT";
+
+    my $self = $class->_new(\%options);
+
+    # we don't want this creating
+    # a cycle in the code, if not
+    # needed
+    weaken($self->{'attribute'});
+
+    return $self;
+}
+
+sub _new {
+    my $class = shift;
+    my $options = @_ == 1 ? $_[0] : {@_};
+
+    $options->{is_inline} ||= 0;
+
+    return bless $options, $class;
+}
+
+## accessors
+
+sub associated_attribute { (shift)->{'attribute'}     }
+sub accessor_type        { (shift)->{'accessor_type'} }
+
+## factory
+
+sub initialize_body {
+    Carp::cluck('The initialize_body method has been made private.'
+        . " The public version is deprecated and will be removed in a future release.\n");
+    shift->_initialize_body;
+}
+
+1;
+
+# XXX - UPDATE DOCS
+__END__
+
+=pod
+
+=head1 NAME
+
+Class::MOP::Method::Attribute - Method Meta Object for accessors
+
+=head1 SYNOPSIS
+
+    use Class::MOP::Method::Accessor;
+
+    my $reader = Class::MOP::Method::Accessor->new(
+        attribute     => $attribute,
+        is_inline     => 1,
+        accessor_type => 'reader',
+    );
+
+    $reader->body->execute($instance); # call the reader method
+
+=head1 DESCRIPTION
+
+This is a subclass of <Class::MOP::Method> which is used by
+C<Class::MOP::Attribute> to generate accessor code. It handles
+generation of readers, writers, predicates and clearers. For each type
+of method, it can either create a subroutine reference, or actually
+inline code by generating a string and C<eval>'ing it.
+
+=head1 METHODS
+
+=over 4
+
+=item B<< Class::MOP::Method::Accessor->new(%options) >>
+
+This returns a new C<Class::MOP::Method::Accessor> based on the
+C<%options> provided.
+
+=over 4
+
+=item * attribute
+
+This is the C<Class::MOP::Attribute> for which accessors are being
+generated. This option is required.
+
+=item * accessor_type
+
+This is a string which should be one of "reader", "writer",
+"accessor", "predicate", or "clearer". This is the type of method
+being generated. This option is required.
+
+=item * is_inline
+
+This indicates whether or not the accessor should be inlined. This
+defaults to false.
+
+=item * name
+
+The method name (without a package name). This is required.
+
+=item * package_name
+
+The package name for the method. This is required.
+
+=back
+
+=item B<< $metamethod->accessor_type >>
+
+Returns the accessor type which was passed to C<new>.
+
+=item B<< $metamethod->is_inline >>
+
+Returns a boolean indicating whether or not the accessor is inlined.
+
+=item B<< $metamethod->associated_attribute >>
+
+This returns the L<Class::MOP::Attribute> object which was passed to
+C<new>.
+
+=item B<< $metamethod->body >>
+
+The method itself is I<generated> when the accessor object is
+constructed.
+
+=back
+
+=head1 AUTHORS
+
+Stevan Little E<lt>stevan@iinteractive.comE<gt>
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright 2006-2009 by Infinity Interactive, Inc.
+
+L<http://www.iinteractive.com>
+
+This library is free software; you can redistribute it and/or modify
+it under the same terms as Perl itself.
+
+=cut
+
diff --git a/lib/Class/MOP/Method/Reader.pm b/lib/Class/MOP/Method/Reader.pm
new file mode 100644
index 0000000..16e636b
--- /dev/null
+++ b/lib/Class/MOP/Method/Reader.pm
@@ -0,0 +1,176 @@
+
+package Class::MOP::Method::Reader;
+
+use strict;
+use warnings;
+
+use Carp         'confess';
+use Scalar::Util 'blessed', 'weaken';
+
+our $VERSION   = '0.88';
+$VERSION = eval $VERSION;
+our $AUTHORITY = 'cpan:STEVAN';
+
+use base 'Class::MOP::Method::Attribute';
+
+sub associated_attribute { (shift)->{'attribute'}     }
+
+## factory
+
+sub _initialize_body {
+    my $self = shift;
+
+    my $method_name = join "_" => (
+        '_generate',
+        'method',
+        ($self->is_inline ? 'inline' : ())
+    );
+
+    $self->{'body'} = $self->$method_name();
+}
+
+## generators
+
+sub generate_method {
+    Carp::cluck('The generate_reader_method method has been made private.'
+        . " The public version is deprecated and will be removed in a future release.\n");
+    shift->_generate_method;
+}
+
+sub _generate_method {
+    my $attr = (shift)->associated_attribute;
+    return sub {
+        confess "Cannot assign a value to a read-only accessor" if @_ > 1;
+        $attr->get_value($_[0]);
+    };
+}
+
+## Inline methods
+
+sub generate_method_inline {
+    Carp::cluck('The generate_reader_method_inline method has been made private.'
+        . " The public version is deprecated and will be removed in a future release.\n");
+    shift->_generate_method_inline;
+}
+
+sub _generate_method_inline {
+    my $self          = shift;
+    my $attr          = $self->associated_attribute;
+    my $attr_name     = $attr->name;
+    my $meta_instance = $attr->associated_class->instance_metaclass;
+
+     my ( $code, $e ) = $self->_eval_closure(
+         {},
+        'sub {'
+        . 'confess "Cannot assign a value to a read-only accessor" if @_ > 1;'
+        . $meta_instance->inline_get_slot_value('$_[0]', $attr_name)
+        . '}'
+    );
+    confess "Could not generate inline reader because : $e" if $e;
+
+    return $code;
+}
+
+1;
+
+# XXX - UPDATE DOCS
+__END__
+
+
+=pod
+
+=head1 NAME
+
+Class::MOP::Method::Reader - Method Meta Object for accessors
+
+=head1 SYNOPSIS
+
+    use Class::MOP::Method::Reader;
+
+    my $reader = Class::MOP::Method::Reader->new(
+        attribute     => $attribute,
+        is_inline     => 1,
+    );
+
+    $reader->body->execute($instance); # call the reader method
+
+=head1 DESCRIPTION
+
+This is a subclass of <Class::MOP::Method> which is used by
+C<Class::MOP::Attribute> to generate accessor code. It handles
+generation of readers, writers, predicates and clearers. For each type
+of method, it can either create a subroutine reference, or actually
+inline code by generating a string and C<eval>'ing it.
+
+=head1 METHODS
+
+=over 4
+
+=item B<< Class::MOP::Method::Accessor->new(%options) >>
+
+This returns a new C<Class::MOP::Method::Accessor> based on the
+C<%options> provided.
+
+=over 4
+
+=item * attribute
+
+This is the C<Class::MOP::Attribute> for which accessors are being
+generated. This option is required.
+
+=item * accessor_type
+
+This is a string which should be one of "reader", "writer",
+"accessor", "predicate", or "clearer". This is the type of method
+being generated. This option is required.
+
+=item * is_inline
+
+This indicates whether or not the accessor should be inlined. This
+defaults to false.
+
+=item * name
+
+The method name (without a package name). This is required.
+
+=item * package_name
+
+The package name for the method. This is required.
+
+=back
+
+=item B<< $metamethod->accessor_type >>
+
+Returns the accessor type which was passed to C<new>.
+
+=item B<< $metamethod->is_inline >>
+
+Returns a boolean indicating whether or not the accessor is inlined.
+
+=item B<< $metamethod->associated_attribute >>
+
+This returns the L<Class::MOP::Attribute> object which was passed to
+C<new>.
+
+=item B<< $metamethod->body >>
+
+The method itself is I<generated> when the accessor object is
+constructed.
+
+=back
+
+=head1 AUTHORS
+
+Stevan Little E<lt>stevan@iinteractive.comE<gt>
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright 2006-2009 by Infinity Interactive, Inc.
+
+L<http://www.iinteractive.com>
+
+This library is free software; you can redistribute it and/or modify
+it under the same terms as Perl itself.
+
+=cut
+
diff --git a/t/000_load.t b/t/000_load.t
index 2507c47..c2552c0 100644
--- a/t/000_load.t
+++ b/t/000_load.t
@@ -1,7 +1,7 @@
 use strict;
 use warnings;
 
-use Test::More tests => 50;
+use Test::More tests => 53;
 
 BEGIN {
     use_ok('Class::MOP');
@@ -15,6 +15,7 @@ BEGIN {
     use_ok('Class::MOP::Method::Inlined');
     use_ok('Class::MOP::Method::Generated');
     use_ok('Class::MOP::Method::Accessor');
+    use_ok('Class::MOP::Method::Attribute');
     use_ok('Class::MOP::Method::Constructor');
     use_ok('Class::MOP::Instance');
     use_ok('Class::MOP::Object');
@@ -27,6 +28,7 @@ my %METAS = (
     'Class::MOP::Method::Inlined' => Class::MOP::Method::Inlined->meta,
     'Class::MOP::Method::Generated' => Class::MOP::Method::Generated->meta,
     'Class::MOP::Method::Accessor'  => Class::MOP::Method::Accessor->meta,
+    'Class::MOP::Method::Attribute'  => Class::MOP::Method::Attribute->meta,
     'Class::MOP::Method::Constructor' =>
         Class::MOP::Method::Constructor->meta,
     'Class::MOP::Package'         => Class::MOP::Package->meta,
@@ -73,6 +75,7 @@ is_deeply(
         Class::MOP::Instance->meta,
         Class::MOP::Method->meta,
         Class::MOP::Method::Accessor->meta,
+        Class::MOP::Method::Attribute->meta,
         Class::MOP::Method::Constructor->meta,
         Class::MOP::Method::Generated->meta,
         Class::MOP::Method::Inlined->meta,
@@ -95,6 +98,7 @@ is_deeply(
             Class::MOP::Instance
             Class::MOP::Method
             Class::MOP::Method::Accessor
+            Class::MOP::Method::Attribute
             Class::MOP::Method::Constructor
             Class::MOP::Method::Generated
             Class::MOP::Method::Inlined
diff --git a/t/005_attributes.t b/t/005_attributes.t
index b7a545b..4ae2095 100644
--- a/t/005_attributes.t
+++ b/t/005_attributes.t
@@ -83,7 +83,7 @@ is($BAZ_ATTR->name, '$baz', '... got the attributes name correctly');
     ::ok($meta->has_method('get_baz'), '... a reader has been created');
     ::ok($meta->has_method('set_baz'), '... a writer has been created');
 
-    ::isa_ok($meta->get_method('get_baz'), 'Class::MOP::Method::Accessor');
+    ::isa_ok($meta->get_method('get_baz'), 'Class::MOP::Method::Reader');
     ::isa_ok($meta->get_method('set_baz'), 'Class::MOP::Method::Accessor');
 }
 
diff --git a/t/014_attribute_introspection.t b/t/014_attribute_introspection.t
index 9c5ab3a..d1532cf 100644
--- a/t/014_attribute_introspection.t
+++ b/t/014_attribute_introspection.t
@@ -1,7 +1,7 @@
 use strict;
 use warnings;
 
-use Test::More tests => 72;
+use Test::More tests => 73;
 use Test::Exception;
 
 use Class::MOP;
@@ -23,6 +23,7 @@ use Class::MOP;
         _set_initial_slot_value
 
         is_lazy
+        method_metaclasses
         name
         has_accessor      accessor
         has_writer        writer
diff --git a/t/072_immutable_w_constructors.t b/t/072_immutable_w_constructors.t
index 906d359..c1705fe 100644
--- a/t/072_immutable_w_constructors.t
+++ b/t/072_immutable_w_constructors.t
@@ -73,7 +73,7 @@ use Class::MOP;
 
     {
         my $bar_accessor = $meta->get_method('bar');
-        isa_ok($bar_accessor, 'Class::MOP::Method::Accessor');
+        isa_ok($bar_accessor, 'Class::MOP::Method::Reader');
         isa_ok($bar_accessor, 'Class::MOP::Method');
 
         ok(!$bar_accessor->is_inline, '... the bar accessor is not inlined');
@@ -119,7 +119,7 @@ use Class::MOP;
     # check out accessors too
     {
         my $bar_accessor = $meta->get_method('bar');
-        isa_ok($bar_accessor, 'Class::MOP::Method::Accessor');
+        isa_ok($bar_accessor, 'Class::MOP::Method::Reader');
         isa_ok($bar_accessor, 'Class::MOP::Method');
 
         ok(!$bar_accessor->is_inline, '... the bar accessor is still not inlined');
@@ -132,13 +132,13 @@ use Class::MOP;
 
     {
         my $bar_accessor = $meta->find_method_by_name('bar');
-        isa_ok($bar_accessor, 'Class::MOP::Method::Accessor');
+        isa_ok($bar_accessor, 'Class::MOP::Method::Reader');
         isa_ok($bar_accessor, 'Class::MOP::Method');
 
         ok(!$bar_accessor->is_inline, '... the bar accessor is not inlined');
 
         my $baz_accessor = $meta->get_method('baz');
-        isa_ok($baz_accessor, 'Class::MOP::Method::Accessor');
+        isa_ok($baz_accessor, 'Class::MOP::Method::Reader');
         isa_ok($baz_accessor, 'Class::MOP::Method');
 
         ok(!$baz_accessor->is_inline, '... the baz accessor is not inlined');
@@ -176,13 +176,13 @@ use Class::MOP;
     # check out accessors too
     {
         my $bar_accessor = $meta->find_method_by_name('bar');
-        isa_ok($bar_accessor, 'Class::MOP::Method::Accessor');
+        isa_ok($bar_accessor, 'Class::MOP::Method::Reader');
         isa_ok($bar_accessor, 'Class::MOP::Method');
 
         ok(!$bar_accessor->is_inline, '... the bar accessor is still not inlined');
 
         my $baz_accessor = $meta->get_method('baz');
-        isa_ok($baz_accessor, 'Class::MOP::Method::Accessor');
+        isa_ok($baz_accessor, 'Class::MOP::Method::Reader');
         isa_ok($baz_accessor, 'Class::MOP::Method');
 
         ok($baz_accessor->is_inline, '... the baz accessor is not inlined');
@@ -195,19 +195,19 @@ use Class::MOP;
 
     {
         my $bar_accessor = $meta->find_method_by_name('bar');
-        isa_ok($bar_accessor, 'Class::MOP::Method::Accessor');
+        isa_ok($bar_accessor, 'Class::MOP::Method::Reader');
         isa_ok($bar_accessor, 'Class::MOP::Method');
 
         ok(!$bar_accessor->is_inline, '... the bar accessor is not inlined');
 
         my $baz_accessor = $meta->find_method_by_name('baz');
-        isa_ok($baz_accessor, 'Class::MOP::Method::Accessor');
+        isa_ok($baz_accessor, 'Class::MOP::Method::Reader');
         isa_ok($baz_accessor, 'Class::MOP::Method');
 
         ok($baz_accessor->is_inline, '... the baz accessor is inlined');
 
         my $bah_accessor = $meta->get_method('bah');
-        isa_ok($bah_accessor, 'Class::MOP::Method::Accessor');
+        isa_ok($bah_accessor, 'Class::MOP::Method::Reader');
         isa_ok($bah_accessor, 'Class::MOP::Method');
 
         ok(!$bah_accessor->is_inline, '... the baz accessor is not inlined');
@@ -245,19 +245,19 @@ use Class::MOP;
     # check out accessors too
     {
         my $bar_accessor = $meta->find_method_by_name('bar');
-        isa_ok($bar_accessor, 'Class::MOP::Method::Accessor');
+        isa_ok($bar_accessor, 'Class::MOP::Method::Reader');
         isa_ok($bar_accessor, 'Class::MOP::Method');
 
         ok(!$bar_accessor->is_inline, '... the bar accessor is still not inlined');
 
         my $baz_accessor = $meta->find_method_by_name('baz');
-        isa_ok($baz_accessor, 'Class::MOP::Method::Accessor');
+        isa_ok($baz_accessor, 'Class::MOP::Method::Reader');
         isa_ok($baz_accessor, 'Class::MOP::Method');
 
         ok($baz_accessor->is_inline, '... the baz accessor is not inlined');
 
         my $bah_accessor = $meta->get_method('bah');
-        isa_ok($bah_accessor, 'Class::MOP::Method::Accessor');
+        isa_ok($bah_accessor, 'Class::MOP::Method::Reader');
         isa_ok($bah_accessor, 'Class::MOP::Method');
 
         ok($bah_accessor->is_inline, '... the baz accessor is not inlined');