From: Fuji, Goro <gfuji@cpan.org>
Date: Thu, 23 Sep 2010 11:25:06 +0000 (+0900)
Subject: Fix add_metaclass_accessor stuff
X-Git-Tag: 0.71~26
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=b4dc931582100f9ec9ec48e0ac1be81cc8e66c84;p=gitmo%2FMouse.git

Fix add_metaclass_accessor stuff
---

diff --git a/lib/Mouse/PurePerl.pm b/lib/Mouse/PurePerl.pm
index 432d4c7..73374b4 100644
--- a/lib/Mouse/PurePerl.pm
+++ b/lib/Mouse/PurePerl.pm
@@ -242,6 +242,27 @@ sub add_method {
     return;
 }
 
+my $generate_class_accessor = sub {
+    my($name) = @_;
+    return sub {
+        my $self = shift;
+        if(@_) {
+            return $self->{$name} = shift;
+        }
+
+        foreach my $class($self->linearized_isa) {
+            my $meta = Mouse::Util::get_metaclass_by_name($class)
+                or next;
+
+            if(exists $meta->{$name}) {
+                return $meta->{$name};
+            }
+        }
+        return undef;
+    };
+};
+
+
 package Mouse::Meta::Class;
 
 use Mouse::Meta::Method::Constructor;
@@ -363,23 +384,9 @@ sub _initialize_object{
 
 sub is_immutable {  $_[0]->{is_immutable} }
 
-sub strict_constructor{
-    my $self = shift;
-    if(@_) {
-        $self->{strict_constructor} = shift;
-    }
-
-    foreach my $class($self->linearized_isa) {
-        my $meta = Mouse::Util::get_metaclass_by_name($class)
-            or next;
-
-        if(exists $meta->{strict_constructor}) {
-            return $meta->{strict_constructor};
-        }
-    }
-
-    return 0; # false
-}
+Mouse::Util::install_subroutines(__PACKAGE__,
+    strict_constructor => $generate_class_accessor->('strict_constructor'),
+);
 
 sub _report_unknown_args {
     my($metaclass, $attrs, $args) = @_;
@@ -447,6 +454,12 @@ sub get_after_method_modifiers {
     return @{ $self->{after_method_modifiers}{$method_name} ||= [] }
 }
 
+sub add_metaclass_accessor { # for meta roles (a.k.a. traits)
+    my($meta, $name) = @_;
+    $meta->add_method($name => $generate_class_accessor->($name));
+    return;
+}
+
 package Mouse::Meta::Attribute;
 
 require Mouse::Meta::Method::Accessor;
@@ -630,7 +643,7 @@ package Mouse::Meta::TypeConstraint;
 
 use overload
     '""' => '_as_string',
-    '0=' => '_identity',
+    '0+' => '_identity',
     '|'  => '_unite',
 
     fallback => 1;
diff --git a/xs-src/Mouse.xs b/xs-src/Mouse.xs
index 8bb69c5..ba123fc 100644
--- a/xs-src/Mouse.xs
+++ b/xs-src/Mouse.xs
@@ -534,18 +534,6 @@ CODE:
     (void)set_slot(methods, name, code); /* $self->{methods}{$name} = $code */
 }
 
-void
-add_class_accessor(SV* self, SV* name)
-CODE:
-{
-    SV* const klass = mouse_call0(self, mouse_name);
-    const char* fq_name = form("%"SVf"::%"SVf, klass, name);
-    STRLEN keylen;
-    const char* const key = SvPV_const(name, keylen);
-    mouse_simple_accessor_generate(aTHX_ fq_name, key, keylen,
-        XS_Mouse_inheritable_class_accessor, NULL, 0);
-}
-
 MODULE = Mouse  PACKAGE = Mouse::Meta::Class
 
 BOOT:
@@ -692,6 +680,18 @@ PPCODE:
     }
 }
 
+void
+add_metaclass_accessor(SV* self, SV* name)
+CODE:
+{
+    SV* const klass = mouse_call0(self, mouse_name);
+    const char* fq_name = form("%"SVf"::%"SVf, klass, name);
+    STRLEN keylen;
+    const char* const key = SvPV_const(name, keylen);
+    mouse_simple_accessor_generate(aTHX_ fq_name, key, keylen,
+        XS_Mouse_inheritable_class_accessor, NULL, 0);
+}
+
 MODULE = Mouse  PACKAGE = Mouse::Object
 
 void