X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FMouse%2FPurePerl.pm;h=535ec983d27f794ae67d036735b5de31eaf82e9a;hb=d6ceb359d08b474a9f0911c7d7c3fd319761b0ae;hp=643795aabfa50ec594484ec45852814a0573e298;hpb=b5956f03156c79cfbdd20f9526f95a9df5aa26b4;p=gitmo%2FMouse.git

diff --git a/lib/Mouse/PurePerl.pm b/lib/Mouse/PurePerl.pm
index 643795a..535ec98 100644
--- a/lib/Mouse/PurePerl.pm
+++ b/lib/Mouse/PurePerl.pm
@@ -288,11 +288,27 @@ sub new_object {
     return $object;
 }
 
+sub clone_object {
+    my $class  = shift;
+    my $object = shift;
+    my $args   = $object->Mouse::Object::BUILDARGS(@_);
+
+    (blessed($object) && $object->isa($class->name))
+        || $class->throw_error("You must pass an instance of the metaclass (" . $class->name . "), not ($object)");
+
+    my $cloned = bless { %$object }, ref $object;
+    $class->_initialize_object($cloned, $args, 1);
+
+    return $cloned;
+}
+
 sub _initialize_object{
     my($self, $object, $args, $is_cloning) = @_;
 
     my @triggers_queue;
 
+    my $used = 0;
+
     foreach my $attribute ($self->get_all_attributes) {
         my $init_arg = $attribute->init_arg;
         my $slot     = $attribute->name;
@@ -306,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) {
@@ -328,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};
@@ -344,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;
 
@@ -717,7 +778,7 @@ Mouse::PurePerl - A Mouse guts in pure Perl
 
 =head1 VERSION
 
-This document describes Mouse version 0.59
+This document describes Mouse version 0.63
 
 =head1 SEE ALSO