X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FMouse%2FPurePerl.pm;h=2a4ba00df388a56ab54410d04a69b973fc3515a6;hb=db562c3b335ff4d8df3095cefdbf95d3c89009d8;hp=5b32267df01aed6a9b0d6a31cfc6a44165d123a3;hpb=86eb0b5e6f0c2d89a6c86516e7bccbf9c7daba1f;p=gitmo%2FMouse.git

diff --git a/lib/Mouse/PurePerl.pm b/lib/Mouse/PurePerl.pm
index 5b32267..2a4ba00 100644
--- a/lib/Mouse/PurePerl.pm
+++ b/lib/Mouse/PurePerl.pm
@@ -156,7 +156,7 @@ sub Str        {
 sub Ref        { ref($_[0]) }
 sub ScalarRef  {
     my($value) = @_;
-    return ref($value) eq 'SCALAR'
+    return ref($value) eq 'SCALAR' || ref($value) eq 'REF';
 }
 sub ArrayRef   { ref($_[0]) eq 'ARRAY'  }
 sub HashRef    { ref($_[0]) eq 'HASH'   }
@@ -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;
@@ -259,7 +280,7 @@ sub is_anon_class{
 
 sub roles { $_[0]->{roles} }
 
-sub linearized_isa { @{ get_linear_isa($_[0]->{package}) } }
+sub linearized_isa { @{ Mouse::Util::get_linear_isa($_[0]->{package}) } }
 
 sub get_all_attributes {
     my($self) = @_;
@@ -273,7 +294,7 @@ sub new_object {
 
     my $object = bless {}, $meta->name;
 
-    $meta->_initialize_object($object, \%args);
+    $meta->_initialize_object($object, \%args, 0);
     # BUILDALL
     if( $object->can('BUILD') ) {
         for my $class (reverse $meta->linearized_isa) {
@@ -296,90 +317,24 @@ sub clone_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;
-
-        if (defined($init_arg) && exists($args->{$init_arg})) {
-            $object->{$slot} = $attribute->_coerce_and_verify($args->{$init_arg}, $object);
-
-            weaken($object->{$slot})
-                if ref($object->{$slot}) && $attribute->is_weak_ref;
-
-            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 && !exists $object->{$slot}) {
-                    my $default = $attribute->default;
-                    my $builder = $attribute->builder;
-                    my $value =   $builder                ? $object->$builder()
-                                : ref($default) eq 'CODE' ? $object->$default()
-                                :                           $default;
-
-                    $object->{$slot} = $attribute->_coerce_and_verify($value, $object);
-
-                    weaken($object->{$slot})
-                        if ref($object->{$slot}) && $attribute->is_weak_ref;
-                }
-            }
-            elsif(!$is_cloning && $attribute->is_required) {
-                $self->throw_error("Attribute (".$attribute->name.") is required");
-            }
-        }
-    }
-
-    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);
-        }
-    }
-
-    if($self->is_anon_class){
-        $object->{__METACLASS__} = $self;
-    }
-
-    return;
+    # The initializer, which is used everywhere, must be clear
+    # when an attribute is added. See Mouse::Meta::Class::add_attribute.
+    my $initializer = $self->{_initialize_object} ||= do {
+        Mouse::Util::load_class($self->constructor_class)
+            ->_generate_initialize_object($self);
+    };
+    goto &{$initializer};
 }
 
 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
-}
+sub strict_constructor;
+*strict_constructor = $generate_class_accessor->('strict_constructor');
 
 sub _report_unknown_args {
     my($metaclass, $attrs, $args) = @_;
@@ -447,6 +402,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;
@@ -628,6 +589,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} }
@@ -710,13 +678,8 @@ sub BUILDARGS {
 
 sub new {
     my $class = shift;
-
-    $class->meta->throw_error('Cannot call new() on an instance') if ref $class;
-
-    my $args = $class->BUILDARGS(@_);
-
-    my $meta = Mouse::Meta::Class->initialize($class);
-    return $meta->new_object($args);
+    my $args  = $class->BUILDARGS(@_);
+    return $class->meta->new_object($args);
 }
 
 sub DESTROY {
@@ -724,9 +687,8 @@ sub DESTROY {
 
     return unless $self->can('DEMOLISH'); # short circuit
 
-    local $?;
-
     my $e = do{
+        local $?;
         local $@;
         eval{
             # DEMOLISHALL
@@ -777,7 +739,7 @@ Mouse::PurePerl - A Mouse guts in pure Perl
 
 =head1 VERSION
 
-This document describes Mouse version 0.70
+This document describes Mouse version 0.72
 
 =head1 SEE ALSO