X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FMouse%2FPurePerl.pm;h=36ef0cef0250beb2b234195b7a44dbe7e5023666;hb=823419c540f9e77090f31f11e04b14477c0372c4;hp=3c7fbd88b20e8f444def25efbe6eae9782526495;hpb=1adf864effeeff1cfdbe79f6014a483860e2ec3f;p=gitmo%2FMouse.git

diff --git a/lib/Mouse/PurePerl.pm b/lib/Mouse/PurePerl.pm
index 3c7fbd8..36ef0ce 100644
--- a/lib/Mouse/PurePerl.pm
+++ b/lib/Mouse/PurePerl.pm
@@ -1,16 +1,14 @@
 package Mouse::PurePerl;
-
-require Mouse::Util;
-
+# The pure Perl backend for Mouse
 package Mouse::Util;
-
 use strict;
 use warnings;
-
-use warnings FATAL => 'redefine'; # to avoid to load Mouse::PurePerl
+use warnings FATAL => 'redefine'; # to avoid to load Mouse::PurePerl twice
 
 use B ();
 
+require Mouse::Util;
+
 
 # taken from Class/MOP.pm
 sub is_valid_class_name {
@@ -148,12 +146,7 @@ sub Value      {  defined($_[0]) && !ref($_[0]) }
 sub Num        {  looks_like_number($_[0]) }
 sub Int        {
     my($value) = @_;
-    looks_like_number($value) && do{
-        # work around RT #55048
-        # This is for more than 32 bit int on 32 bit systems
-        require POSIX;
-        POSIX::fmod($value, 1) == 0;
-    };
+    looks_like_number($value) && $value =~ /\A [+-]? [0-9]+  \z/xms;
 }
 sub Str        {
     my($value) = @_;
@@ -249,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;
@@ -275,20 +289,45 @@ sub get_all_attributes {
 }
 
 sub new_object {
-    my $self = shift;
+    my $meta = shift;
     my %args = (@_ == 1 ? %{$_[0]} : @_);
 
-    my $object = bless {}, $self->name;
+    my $object = bless {}, $meta->name;
+
+    $meta->_initialize_object($object, \%args);
+    # BUILDALL
+    if( $object->can('BUILD') ) {
+        for my $class (reverse $meta->linearized_isa) {
+            my $build = Mouse::Util::get_code_ref($class, 'BUILD')
+                || next;
 
-    $self->_initialize_object($object, \%args);
+            $object->$build(\%args);
+        }
+    }
     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, $ignore_triggers) = @_;
+    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;
@@ -302,10 +341,11 @@ 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) {
-                if (!$attribute->is_lazy) {
+                if (!$attribute->is_lazy && !exists $object->{$slot}) {
                     my $default = $attribute->default;
                     my $builder = $attribute->builder;
                     my $value =   $builder                ? $object->$builder()
@@ -318,13 +358,17 @@ sub _initialize_object{
                         if ref($object->{$slot}) && $attribute->is_weak_ref;
                 }
             }
-            elsif($attribute->is_required) {
+            elsif(!$is_cloning && $attribute->is_required) {
                 $self->throw_error("Attribute (".$attribute->name.") is required");
             }
         }
     }
 
-    if(!$ignore_triggers){
+    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};
             $trigger->($object, $value);
@@ -340,7 +384,32 @@ sub _initialize_object{
 
 sub is_immutable {  $_[0]->{is_immutable} }
 
-sub __strict_constructor{ $_[0]->{strict_constructor} }
+sub strict_constructor;
+*strict_constructor = $generate_class_accessor->('strict_constructor');
+
+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;
 
@@ -384,6 +453,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;
@@ -417,6 +492,7 @@ sub should_auto_deref    { $_[0]->{auto_deref}             }
 sub should_coerce        { $_[0]->{coerce}                 }
 
 sub documentation        { $_[0]->{documentation}          }
+sub insertion_order      { $_[0]->{insertion_order}        }
 
 # predicates
 
@@ -564,6 +640,13 @@ sub _process_options{
 
 package Mouse::Meta::TypeConstraint;
 
+use overload
+    '""' => '_as_string',
+    '0+' => '_identity',
+    '|'  => '_unite',
+
+    fallback => 1;
+
 sub name    { $_[0]->{name}    }
 sub parent  { $_[0]->{parent}  }
 sub message { $_[0]->{message} }
@@ -622,6 +705,12 @@ sub compile_type_constraint{
     return;
 }
 
+sub check {
+    my $self = shift;
+    return $self->_compiled_type_constraint->(@_);
+}
+
+
 package Mouse::Object;
 
 sub BUILDARGS {
@@ -646,19 +735,7 @@ sub new {
     my $args = $class->BUILDARGS(@_);
 
     my $meta = Mouse::Meta::Class->initialize($class);
-    my $self = $meta->new_object($args);
-
-    # BUILDALL
-    if( $self->can('BUILD') ) {
-        for my $class (reverse $meta->linearized_isa) {
-            my $build = Mouse::Util::get_code_ref($class, 'BUILD')
-                || next;
-
-            $self->$build($args);
-        }
-    }
-
-    return $self;
+    return $meta->new_object($args);
 }
 
 sub DESTROY {
@@ -719,7 +796,7 @@ Mouse::PurePerl - A Mouse guts in pure Perl
 
 =head1 VERSION
 
-This document describes Mouse version 0.50_05
+This document describes Mouse version 0.70
 
 =head1 SEE ALSO