From: gfx <gfuji@cpan.org>
Date: Tue, 6 Jul 2010 11:15:05 +0000 (+0900)
Subject: Make strict_constructor public
X-Git-Tag: 0.62~2
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?p=gitmo%2FMouse.git;a=commitdiff_plain;h=fb4ddd8813b802fcd34aef915c5e7ce3d10e3022

Make strict_constructor public
---

diff --git a/lib/Mouse/Meta/Class.pm b/lib/Mouse/Meta/Class.pm
index b1cffd8..f2adb02 100644
--- a/lib/Mouse/Meta/Class.pm
+++ b/lib/Mouse/Meta/Class.pm
@@ -258,8 +258,6 @@ sub make_immutable {
 
     $self->{is_immutable}++;
 
-    $self->{strict_constructor} = $args{strict_constructor};
-
     if ($args{inline_constructor}) {
         $self->add_method($args{constructor_name} =>
             Mouse::Util::load_class($self->constructor_class)
diff --git a/lib/Mouse/Meta/Method/Constructor.pm b/lib/Mouse/Meta/Method/Constructor.pm
index 7435aea..3c68a80 100644
--- a/lib/Mouse/Meta/Method/Constructor.pm
+++ b/lib/Mouse/Meta/Method/Constructor.pm
@@ -51,7 +51,7 @@ sub _generate_processattrs {
     my @res;
 
     my $has_triggers;
-    my $strict = $metaclass->__strict_constructor;
+    my $strict = $metaclass->strict_constructor;
 
     if($strict){
         push @res, 'my $used = 0;';
@@ -152,7 +152,7 @@ sub _generate_processattrs {
 
     if($strict){
         push @res, q{if($used < keys %{$args})}
-            . sprintf q{{ %s->_report_unknown_args($metaclass, \@attrs, $args) }}, $method_class;
+            . q{{ $metaclass->_report_unknown_args(\@attrs, $args) }};
     }
 
     if($metaclass->is_anon_class){
@@ -202,30 +202,6 @@ sub _generate_BUILDALL {
     return join "\n", @code;
 }
 
-sub _report_unknown_args {
-    my(undef, $metaclass, $attrs, $args) = @_;
-
-    my @unknowns;
-    my %init_args;
-    foreach my $attr(@{$attrs}){
-        my $init_arg = $attr->init_arg;
-        if(defined $init_arg){
-            $init_args{$init_arg}++;
-        }
-    }
-
-    while(my $key = each %{$args}){
-        if(!exists $init_args{$key}){
-            push @unknowns, $key;
-        }
-    }
-
-    $metaclass->throw_error( sprintf
-        "Unknown attribute passed to the constructor of %s: %s",
-        $metaclass->name, Mouse::Util::english_list(@unknowns),
-    );
-}
-
 1;
 __END__
 
diff --git a/lib/Mouse/PurePerl.pm b/lib/Mouse/PurePerl.pm
index 8285fa7..4db48db 100644
--- a/lib/Mouse/PurePerl.pm
+++ b/lib/Mouse/PurePerl.pm
@@ -307,6 +307,8 @@ sub _initialize_object{
 
     my @triggers_queue;
 
+    my $used = 0;
+
     foreach my $attribute ($self->get_all_attributes) {
         my $init_arg = $attribute->init_arg;
         my $slot     = $attribute->name;
@@ -320,6 +322,7 @@ sub _initialize_object{
             if ($attribute->has_trigger) {
                 push @triggers_queue, [ $attribute->trigger, $object->{$slot} ];
             }
+            $used++;
         }
         else { # no init arg
             if ($attribute->has_default || $attribute->has_builder) {
@@ -342,6 +345,10 @@ sub _initialize_object{
         }
     }
 
+    if($used < keys %{$args} && $self->strict_constructor) {
+        $self->_report_unknown_args([ $self->get_all_attributes ], $args);
+    }
+
     if(@triggers_queue){
         foreach my $trigger_and_value(@triggers_queue){
             my($trigger, $value) = @{$trigger_and_value};
@@ -358,7 +365,47 @@ sub _initialize_object{
 
 sub is_immutable {  $_[0]->{is_immutable} }
 
-sub __strict_constructor{ $_[0]->{strict_constructor} }
+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
+}
+
+sub _report_unknown_args {
+    my($metaclass, $attrs, $args) = @_;
+
+    my @unknowns;
+    my %init_args;
+    foreach my $attr(@{$attrs}){
+        my $init_arg = $attr->init_arg;
+        if(defined $init_arg){
+            $init_args{$init_arg}++;
+        }
+    }
+
+    while(my $key = each %{$args}){
+        if(!exists $init_args{$key}){
+            push @unknowns, $key;
+        }
+    }
+
+    $metaclass->throw_error( sprintf
+        "Unknown attribute passed to the constructor of %s: %s",
+        $metaclass->name, Mouse::Util::english_list(@unknowns),
+    );
+}
 
 package Mouse::Meta::Role;
 
diff --git a/mouse.h b/mouse.h
index 8764f8a..8e95932 100644
--- a/mouse.h
+++ b/mouse.h
@@ -29,6 +29,7 @@
 #define no_mro_get_linear_isa
 #define mro_get_linear_isa(stash) mouse_mro_get_linear_isa(aTHX_ stash)
 AV* mouse_mro_get_linear_isa(pTHX_ HV* const stash);
+#define mro_method_changed_in(stash) ((void)((stash), ++PL_sub_generation))
 #endif /* !mro_get_linear_isa */
 
 #ifndef mro_get_pkg_gen
diff --git a/t/001_mouse/068-strict-constructor.t b/t/001_mouse/068-strict-constructor.t
index cd38d21..3a325a8 100644
--- a/t/001_mouse/068-strict-constructor.t
+++ b/t/001_mouse/068-strict-constructor.t
@@ -5,6 +5,7 @@ use warnings;
 use if 'Mouse' eq 'Moose',
     'Test::More' => skip_all => 'Moose does nots support strict constructor';
 use Test::More;
+use Test::Mouse;
 use Test::Exception;
 
 {
@@ -25,41 +26,50 @@ use Test::Exception;
         default => 42,
     );
 
-    __PACKAGE__->meta->make_immutable(strict_constructor => 1);
+    __PACKAGE__->meta->strict_constructor(1);
+}
+{
+    package MySubClass;
+    use Mouse;
+    extends 'MyClass';
 }
 
-lives_and {
-    my $o = MyClass->new(foo => 1);
-    isa_ok($o, 'MyClass');
-    is $o->baz, 42;
-} 'correc use of the constructor';
-
-lives_and {
-    my $o = MyClass->new(foo => 1, baz => 10);
-    isa_ok($o, 'MyClass');
-    is $o->baz, 10;
-} 'correc use of the constructor';
-
-
-throws_ok {
-    MyClass->new(foo => 1, hoge => 42);
-} qr/\b hoge \b/xms;
-
-throws_ok {
-    MyClass->new(foo => 1, bar => 42);
-} qr/\b bar \b/xms, "init_arg => undef";
-
-
-throws_ok {
-    MyClass->new(aaa => 1, bbb => 2, ccc => 3);
-} qr/\b aaa \b/xms, $@;
-
-throws_ok {
-    MyClass->new(aaa => 1, bbb => 2, ccc => 3);
-} qr/\b bbb \b/xms, $@;
-
-throws_ok {
-    MyClass->new(aaa => 1, bbb => 2, ccc => 3);
-} qr/\b ccc \b/xms, $@;
+with_immutable sub {
+    lives_and {
+        my $o = MyClass->new(foo => 1);
+        isa_ok($o, 'MyClass');
+        is $o->baz, 42;
+    } 'correc use of the constructor';
+
+    lives_and {
+        my $o = MyClass->new(foo => 1, baz => 10);
+        isa_ok($o, 'MyClass');
+        is $o->baz, 10;
+    } 'correc use of the constructor';
+
+
+    throws_ok {
+        MyClass->new(foo => 1, hoge => 42);
+    } qr/\b hoge \b/xms;
+
+    throws_ok {
+        MyClass->new(foo => 1, bar => 42);
+    } qr/\b bar \b/xms, "init_arg => undef";
+
+
+    eval {
+        MyClass->new(aaa => 1, bbb => 2, ccc => 3);
+    };
+    like $@, qr/\b aaa \b/xms;
+    like $@, qr/\b bbb \b/xms;
+    like $@, qr/\b ccc \b/xms;
+
+    eval {
+        MySubClass->new(aaa => 1, bbb => 2, ccc => 3);
+    };
+    like $@, qr/\b aaa \b/xms;
+    like $@, qr/\b bbb \b/xms;
+    like $@, qr/\b ccc \b/xms;
+}, qw(MyClass MySubClass);
 
 done_testing;
diff --git a/xs-src/Mouse.xs b/xs-src/Mouse.xs
index 250604d..ecc6e8c 100644
--- a/xs-src/Mouse.xs
+++ b/xs-src/Mouse.xs
@@ -123,7 +123,7 @@ mouse_class_update_xc(pTHX_ SV* const metaclass PERL_UNUSED_DECL, HV* const stas
         flags |= MOUSEf_XC_HAS_BUILDARGS;
     }
 
-    if(predicate_calls(metaclass, "__strict_constructor")){
+    if(predicate_calls(metaclass, "strict_constructor")){
         flags |= MOUSEf_XC_CONSTRUCTOR_IS_STRICT;
     }
 
@@ -297,7 +297,7 @@ mouse_class_initialize_object(pTHX_ SV* const meta, SV* const object, HV* const
     I32 const len   = AvFILLp(attrs) + 1;
     I32 i;
     AV* triggers_queue = NULL;
-    I32 used = 0;
+    U32 used = 0;
 
     assert(meta || object);
     assert(args);
@@ -525,8 +525,6 @@ BOOT:
     INSTALL_SIMPLE_PREDICATE_WITH_KEY(Class, is_anon_class, anon_serial_id);
     INSTALL_SIMPLE_READER(Class, is_immutable);
 
-    INSTALL_SIMPLE_READER_WITH_KEY(Class, __strict_constructor,     strict_constructor);
-
     INSTALL_CLASS_HOLDER(Class, method_metaclass,     "Mouse::Meta::Method");
     INSTALL_CLASS_HOLDER(Class, attribute_metaclass,  "Mouse::Meta::Attribute");
     INSTALL_CLASS_HOLDER(Class, constructor_class,    "Mouse::Meta::Method::Constructor::XS");
@@ -613,6 +611,45 @@ CODE:
     mouse_class_initialize_object(aTHX_ meta, object, args, is_cloning);
 }
 
+void
+strict_constructor(SV* self, SV* value = NULL)
+CODE:
+{
+    SV* const slot      = sv_2mortal(newSVpvs_share("strict_constructor"));
+    SV* const stash_ref = mcall0(self, mouse_namespace);
+    HV* stash;
+
+    if(!(SvROK(stash_ref) && SvTYPE(SvRV(stash_ref)) == SVt_PVHV)) {
+        croak("namespace() didn't return a HASH reference");
+    }
+    stash = (HV*)SvRV(stash_ref);
+
+    if(value) { /* setter */
+        set_slot(self, slot, value);
+        mro_method_changed_in(stash);
+    }
+
+    value = get_slot(self, slot);
+
+    if(!value) {
+        AV* const isa   = mro_get_linear_isa(stash);
+        I32 const len   = av_len(isa) + 1;
+        I32 i;
+        for(i = 1; i < len; i++) {
+            SV* const klass = MOUSE_av_at(isa, i);
+            SV* const meta  = get_metaclass(klass);
+            if(!SvOK(meta)){
+                continue; /* skip non-Mouse classes */
+            }
+            value = get_slot(meta, slot);
+            if(value) {
+                break;
+            }
+        }
+    }
+    ST(0) = value ? value : &PL_sv_no;
+}
+
 MODULE = Mouse  PACKAGE = Mouse::Meta::Role
 
 BOOT: