From: gfx <gfuji@cpan.org>
Date: Fri, 2 Oct 2009 11:59:23 +0000 (+0900)
Subject: Add get_read_method_ref and get_write_method_ref. Remove get_read_method and get_writ... 
X-Git-Tag: 0.37_02~29
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=2a464664052830d5fad036569d5ccb3964c7f592;p=gitmo%2FMouse.git

Add get_read_method_ref and get_write_method_ref. Remove get_read_method and get_write_method.
---

diff --git a/lib/Mouse/Meta/Attribute.pm b/lib/Mouse/Meta/Attribute.pm
index 4c24850..03b2907 100644
--- a/lib/Mouse/Meta/Attribute.pm
+++ b/lib/Mouse/Meta/Attribute.pm
@@ -185,9 +185,6 @@ sub builder              { $_[0]->{builder}                }
 sub should_auto_deref    { $_[0]->{auto_deref}             }
 sub should_coerce        { $_[0]->{coerce}                 }
 
-sub get_read_method      { $_[0]->{reader} || $_[0]->{accessor} }
-sub get_write_method     { $_[0]->{writer} || $_[0]->{accessor} }
-
 # predicates
 
 sub has_accessor         { exists $_[0]->{accessor}        }
@@ -356,6 +353,44 @@ sub get_parent_args {
     $self->throw_error("Could not find an attribute by the name of '$name' to inherit from");
 }
 
+
+#sub get_read_method      { $_[0]->{reader} || $_[0]->{accessor} }
+#sub get_write_method     { $_[0]->{writer} || $_[0]->{accessor} }
+
+sub get_read_method_ref{
+    my($self) = @_;
+
+    $self->{_read_method_ref} ||= do{
+        my $metaclass = $self->associated_class
+            or $self->throw_error('No asocciated class for ' . $self->name);
+
+        my $reader = $self->{reader} || $self->{accessor};
+        if($reader){
+            $metaclass->name->can($reader);
+        }
+        else{
+            Mouse::Meta::Method::Accessor->_generate_reader($self, undef, $metaclass);
+        }
+    };
+}
+
+sub get_write_method_ref{
+    my($self) = @_;
+
+    $self->{_write_method_ref} ||= do{
+        my $metaclass = $self->associated_class
+            or $self->throw_error('No asocciated class for ' . $self->name);
+
+        my $reader = $self->{writer} || $self->{accessor};
+        if($reader){
+            $metaclass->name->can($reader);
+        }
+        else{
+            Mouse::Meta::Method::Accessor->_generate_writer($self, undef, $metaclass);
+        }
+    };
+}
+
 sub associate_method{
     my ($attribute, $method) = @_;
     $attribute->{associated_methods}++;
@@ -369,7 +404,7 @@ sub install_accessors{
 
     foreach my $type(qw(accessor reader writer predicate clearer handles)){
         if(exists $attribute->{$type}){
-            my $installer    = '_install_' . $type;
+            my $installer    = '_generate_' . $type;
 
             Mouse::Meta::Method::Accessor->$installer($attribute, $attribute->{$type}, $metaclass);
 
diff --git a/lib/Mouse/Meta/Class.pm b/lib/Mouse/Meta/Class.pm
index 5724ebf..85066c7 100644
--- a/lib/Mouse/Meta/Class.pm
+++ b/lib/Mouse/Meta/Class.pm
@@ -117,7 +117,7 @@ sub add_attribute {
             my($attribute_class, @traits) = Mouse::Meta::Attribute->interpolate_class($name, \%args);
             $args{traits} = \@traits if @traits;
 
-            $attr = $attribute_class->new($name, \%args);
+            $attr = $attribute_class->new($name, %args);
         }
     }
 
@@ -248,17 +248,20 @@ sub make_immutable {
     my %args = (
         inline_constructor => 1,
         inline_destructor  => 1,
+        constructor_name   => 'new',
         @_,
     );
 
     $self->{is_immutable}++;
 
     if ($args{inline_constructor}) {
-        $self->add_method('new' => Mouse::Meta::Method::Constructor->generate_constructor_method_inline( $self ));
+        # generate and install
+        Mouse::Meta::Method::Constructor->_generate_constructor_method($self, \%args);
     }
 
     if ($args{inline_destructor}) {
-        $self->add_method('DESTROY' => Mouse::Meta::Method::Destructor->generate_destructor_method_inline( $self ));
+        # generate and install
+        Mouse::Meta::Method::Destructor->_generate_destructor_method($self, \%args);
     }
 
     # Moose's make_immutable returns true allowing calling code to skip setting an explicit true value
diff --git a/lib/Mouse/Meta/Method/Accessor.pm b/lib/Mouse/Meta/Method/Accessor.pm
index eb9152d..621a259 100755
--- a/lib/Mouse/Meta/Method/Accessor.pm
+++ b/lib/Mouse/Meta/Method/Accessor.pm
@@ -3,7 +3,7 @@ use strict;
 use warnings;
 use Scalar::Util qw(blessed);
 
-sub _install_accessor{
+sub _generate_accessor{
     my (undef, $attribute, $method_name, $class, $type) = @_;
 
     my $name          = $attribute->name;
@@ -24,7 +24,8 @@ sub _install_accessor{
 
     my $accessor = 
         '#line ' . __LINE__ . ' "' . __FILE__ . "\"\n" .
-        "sub {\n";
+        sprintf("sub %s {\n", defined($method_name) ? $class->name . '::' . $method_name : '');
+
     if ($type eq 'accessor' || $type eq 'writer') {
         if($type eq 'accessor'){
             $accessor .= 
@@ -34,7 +35,7 @@ sub _install_accessor{
         else{ # writer
             $accessor .= 
                 '#line ' . __LINE__ . ' "' . __FILE__ . "\"\n" .
-                'if(@_ < 2){ Carp::confess("Not enough arguments for writer '.$method_name.'") }'.
+                'if(@_ < 2){ Carp::confess("Not enough arguments for the writer of '.$name.'") }'.
                 '{' . "\n";
         }
                 
@@ -117,27 +118,29 @@ sub _install_accessor{
     $accessor .= 'return '.$self.'->{'.$key."};\n}";
 
     #print $accessor, "\n";
-    my $code = eval $accessor;
-    $attribute->throw_error($@) if $@;
-
-    $class->add_method($method_name => $code);
-    return;
+    my $code;
+    my $e = do{
+        local $@;
+        $code = eval $accessor;
+        $@;
+    };
+    die $e if $e;
+
+    return $code; # returns a CODE ref unless $method_name is passed
 }
 
-sub _install_reader{
+sub _generate_reader{
     my $class = shift;
-    $class->_install_accessor(@_, 'reader');
-    return;
+    return $class->_generate_accessor(@_, 'reader');
 }
 
-sub _install_writer{
+sub _generate_writer{
     my $class = shift;
-    $class->_install_accessor(@_, 'writer');
-    return;
+    return $class->_generate_accessor(@_, 'writer');
 }
 
 
-sub _install_predicate {
+sub _generate_predicate {
     my (undef, $attribute, $method_name, $class) = @_;
 
     my $slot = $attribute->name;
@@ -148,7 +151,7 @@ sub _install_predicate {
     return;
 }
 
-sub _install_clearer {
+sub _generate_clearer {
     my (undef, $attribute, $method_name, $class) = @_;
 
     my $slot = $attribute->name;
@@ -159,7 +162,7 @@ sub _install_clearer {
     return;
 }
 
-sub _install_handles {
+sub _generate_handles {
     my (undef, $attribute, $handles, $class) = @_;
 
     my $reader  = $attribute->reader || $attribute->accessor
diff --git a/lib/Mouse/Meta/Method/Constructor.pm b/lib/Mouse/Meta/Method/Constructor.pm
index f957750..5ecbf90 100644
--- a/lib/Mouse/Meta/Method/Constructor.pm
+++ b/lib/Mouse/Meta/Method/Constructor.pm
@@ -2,8 +2,8 @@ package Mouse::Meta::Method::Constructor;
 use strict;
 use warnings;
 
-sub generate_constructor_method_inline {
-    my ($class, $metaclass) = @_;
+sub _generate_constructor_method {
+    my ($class, $metaclass, $args) = @_;
 
     my $associated_metaclass_name = $metaclass->name;
     my @attrs         = $metaclass->get_all_attributes;
@@ -15,17 +15,21 @@ sub generate_constructor_method_inline {
     my @compiled_constraints = map { $_ ? $_->_compiled_type_constraint : undef }
                                map { $_->type_constraint } @attrs;
 
+    my $constructor_name = defined($args->{constructor_name})
+        ? $associated_metaclass_name . '::' . $args->{constructor_name}
+        : '';
+
     my $code = sprintf("#line %d %s\n", __LINE__, __FILE__).<<"...";
-    sub {
-        my \$class = shift;
-        return \$class->Mouse::Object::new(\@_)
-            if \$class ne q{$associated_metaclass_name};
-        $buildargs;
-        my \$instance = bless {}, \$class;
-        $processattrs;
-        $buildall;
-        return \$instance;
-    }
+        sub $constructor_name \{
+            my \$class = shift;
+            return \$class->Mouse::Object::new(\@_)
+                if \$class ne q{$associated_metaclass_name};
+            $buildargs;
+            my \$instance = bless {}, \$class;
+            $processattrs;
+            $buildall;
+            return \$instance;
+        }
 ...
 
     local $@;
diff --git a/lib/Mouse/Meta/Method/Destructor.pm b/lib/Mouse/Meta/Method/Destructor.pm
index fa0d025..c3d2a0d 100644
--- a/lib/Mouse/Meta/Method/Destructor.pm
+++ b/lib/Mouse/Meta/Method/Destructor.pm
@@ -2,13 +2,15 @@ package Mouse::Meta::Method::Destructor;
 use strict;
 use warnings;
 
-sub generate_destructor_method_inline {
-    my ($class, $meta) = @_;
+sub _empty_destroy{ }
+
+sub _generate_destructor_method {
+    my ($class, $metaclass) = @_;
 
     my $demolishall = do {
-        if ($meta->name->can('DEMOLISH')) {
+        if ($metaclass->name->can('DEMOLISH')) {
             my @code = ();
-            for my $class ($meta->linearized_isa) {
+            for my $class ($metaclass->linearized_isa) {
                 no strict 'refs';
                 if (*{$class . '::DEMOLISH'}{CODE}) {
                     push @code, "${class}::DEMOLISH(\$self);";
@@ -16,21 +18,26 @@ sub generate_destructor_method_inline {
             }
             join "\n", @code;
         } else {
-            return sub { }; # no demolish =)
+            $metaclass->add_method(DESTROY => \&_empty_destroy);
+            return;
         }
     };
 
-    my $code = <<"...";
-    sub {
+    my $destructor_name = $metaclass->name . '::DESTROY';
+    my $code = sprintf("#line %d %s\n", __LINE__, __FILE__) . <<"...";
+    sub $destructor_name \{
         my \$self = shift;
         $demolishall;
     }
 ...
 
-    local $@;
-    my $res = eval $code;
+    my $e = do{
+        local $@;
+        eval $code;
+        $@;
+    };
     die $@ if $@;
-    return $res;
+    return;
 }
 
 1;
diff --git a/t/000-recipes/moose_cookbook_meta_recipe3.t b/t/000-recipes/moose_cookbook_meta_recipe3.t
index b77d293..596fe35 100644
--- a/t/000-recipes/moose_cookbook_meta_recipe3.t
+++ b/t/000-recipes/moose_cookbook_meta_recipe3.t
@@ -53,7 +53,7 @@ $| = 1;
               $dump .= $name;
           }
 
-          my $reader = $attribute->get_read_method;
+          my $reader = $attribute->get_read_method_ref;
           $dump .= ": " . $self->$reader . "\n";
       }
 
diff --git a/t/020_attributes/015_attribute_traits.t b/t/020_attributes/015_attribute_traits.t
index aaa6ece..9d89cf5 100644
--- a/t/020_attributes/015_attribute_traits.t
+++ b/t/020_attributes/015_attribute_traits.t
@@ -21,7 +21,7 @@ use Test::Mouse;
 
     after 'install_accessors' => sub {
         my $self = shift;
-        my $reader = $self->get_read_method;
+        my $reader = $self->get_read_method_ref;
 
         $self->associated_class->add_method(
             $self->alias_to,
diff --git a/t/044-attribute-metaclass.t b/t/044-attribute-metaclass.t
index 71fdd11..2e05376 100644
--- a/t/044-attribute-metaclass.t
+++ b/t/044-attribute-metaclass.t
@@ -1,7 +1,7 @@
 #!/usr/bin/env perl
 use strict;
 use warnings;
-use Test::More tests => 5;
+use Test::More tests => 7;
 use lib 't/lib';
 
 do {
@@ -56,8 +56,8 @@ do {
 
     # extend the parents stuff to make sure
     # certain bits are now required ...
-    #has '+default'         => (required => 1);
-    #has '+type_constraint' => (required => 1);
+    #has 'default'         => (required => 1);
+    has 'type_constraint' => (required => 1);
 
     ## Methods called prior to instantiation
 
@@ -131,8 +131,8 @@ do {
         # grab the reader and writer methods
         # as well, this will be useful for
         # our method provider constructors
-        my $attr_reader = $attr->get_read_method;
-        my $attr_writer = $attr->get_write_method;
+        my $attr_reader = $attr->get_read_method_ref;
+        my $attr_writer = $attr->get_write_method_ref;
 
 
         # before we install them, lets
@@ -213,6 +213,10 @@ do {
                     my ($attr, $reader, $writer) = @_;
                     return sub { $_[0]->$writer($_[1]) };
                 },
+                get => sub {
+                    my ($attr, $reader, $writer) = @_;
+                    return sub { $_[0]->$reader() };
+                },
                 add => sub {
                     my ($attr, $reader, $writer) = @_;
                     return sub { $_[0]->$writer($_[0]->$reader() + $_[1]) };
@@ -273,11 +277,12 @@ do {
     use Mouse;
 
     has 'ii' => (
-        is  => 'rw',
         isa => 'Num',
         provides => {
             sub => 'ii_minus',
             abs => 'ii_abs',
+            get => 'get_ii',
+            set => 'set_ii',
        },
 
        traits => [qw(MyNumber)],
@@ -293,6 +298,10 @@ can_ok 'MyClassWithTraits', qw(ii_minus ii_abs);
 
 $k = MyClassWithTraits->new(ii => 10);
 $k->ii_minus(100);
-is $k->ii,    -90;
-is $k->ii_abs, 90;
+is $k->get_ii, -90;
+is $k->ii_abs,  90;
+
+$k->set_ii(10);
+is $k->get_ii, 10;
+is $k->ii_abs, 10;