From: Stevan Little <stevan.little@iinteractive.com>
Date: Thu, 7 Feb 2008 15:16:42 +0000 (+0000)
Subject: more tests and the constructor stuff as well
X-Git-Tag: 0_37~2
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=9df136d0ec3963a967e8ac7fdfacffa3e0d50cd9;hp=cdeb30dc5c93d3b1b46192d2d6f2ac35763d1a4c;p=gitmo%2FMoose.git

more tests and the constructor stuff as well
---

diff --git a/Changes b/Changes
index f969fa3..3002005 100644
--- a/Changes
+++ b/Changes
@@ -8,7 +8,7 @@ Revision history for Perl extension Moose
       - 'has' now dies if you don't pass in name 
         value pairs
       - added the 'make_immutable' keyword as a shortcut
-        to __PACKAGE__->meta->make_immutable
+        to make_immutable
 
     * Moose::Meta::Class
       Moose::Meta::Method::Constructor
diff --git a/benchmarks/caf_vs_moose.pl b/benchmarks/caf_vs_moose.pl
index 2634484..3583bc1 100644
--- a/benchmarks/caf_vs_moose.pl
+++ b/benchmarks/caf_vs_moose.pl
@@ -11,13 +11,13 @@
     package MooseImmutable;
     use Moose;
     has foo => (is => 'rw');
-    __PACKAGE__->meta->make_immutable();
+    make_immutable();
 }
 {
     package MooseImmutable::NoConstructor;
     use Moose;
     has foo => (is => 'rw');
-    __PACKAGE__->meta->make_immutable(inline_constructor => 0);
+    make_immutable(inline_constructor => 0);
 }
 {
     package ClassAccessorFast;
diff --git a/lib/Moose/Meta/Method/Accessor.pm b/lib/Moose/Meta/Method/Accessor.pm
index a5e0e80..30efaa6 100644
--- a/lib/Moose/Meta/Method/Accessor.pm
+++ b/lib/Moose/Meta/Method/Accessor.pm
@@ -24,9 +24,9 @@ sub _eval_code {
 
     my $type_constraint_obj  = $attr->type_constraint;
     my $type_constraint_name = $type_constraint_obj && $type_constraint_obj->name;
-    my $type_constraint = $type_constraint_obj
-                                ? $type_constraint_obj->_compiled_type_constraint
-                                : undef;
+    my $type_constraint      = $type_constraint_obj
+                                   ? $type_constraint_obj->_compiled_type_constraint
+                                   : undef;
 
     my $sub = eval $code;
     confess "Could not create writer for '$attr_name' because $@ \n code: $code" if $@;
@@ -176,31 +176,41 @@ sub _inline_check_lazy {
             $code .= '    ($type_constraint->($default))' .
                      '            || confess "Attribute (" . $attr_name . ") does not pass the type constraint ("' .
                      '           . $type_constraint_name . ") with " . (defined($default) ? overload::StrVal($default) : "undef")' .
-                     '          if defined($default);' . "\n" .
-                     '        ' . $slot_access . ' = $default; ' . "\n";
+                     '          if defined($default);' . "\n";
+            $code .= '    ' . $self->_inline_init_slot($attr, $inv, $slot_access, '$default') . "\n";
         } 
         else {
-            $code .= '    ' . $slot_access . " = undef; \n";
+            $code .= '    ' . $self->_inline_init_slot($attr, $inv, $slot_access, 'undef') . "\n";
         }
 
     } else {
         if ($attr->has_default) {
-            $code .= '    '.$slot_access.' = $attr->default(' . $inv . ');'."\n";
+            $code .= '    ' . $self->_inline_init_slot($attr, $inv, $slot_access, ('$attr->default(' . $inv . ')')) . "\n";            
         } 
         elsif ($attr->has_builder) {
-            $code .= '    if(my $builder = '.$inv.'->can($attr->builder)){ '."\n".
-                     '        '.$slot_access.' = '.$inv.'->$builder; '. "\n    } else {\n" .
+            $code .= '    if (my $builder = '.$inv.'->can($attr->builder)) { ' . "\n" 
+                  .  '       ' . $self->_inline_init_slot($attr, $inv, $slot_access, ($inv . '->$builder'))           
+                     . "\n    } else {\n" .
                      '        confess(Scalar::Util::blessed('.$inv.')." does not support builder method '.
                      '\'".$attr->builder."\' for attribute \'" . $attr->name . "\'");'. "\n    }";
         } 
         else {
-            $code .= '    ' . $slot_access . " = undef; \n";
+            $code .= '    ' . $self->_inline_init_slot($attr, $inv, $slot_access, 'undef') . "\n";
         }
     }
     $code .= "}\n";
     return $code;
 }
 
+sub _inline_init_slot {
+    my ($self, $attr, $inv, $slot_access, $value) = @_;
+    if ($attr->has_initializer) {
+        return ('$attr->set_initial_value(' . $inv . ', ' . $value . ');');
+    }
+    else {
+        return ($slot_access . ' = ' . $value . ';');
+    }    
+}
 
 sub _inline_store {
     my ($self, $instance, $value) = @_;
diff --git a/lib/Moose/Meta/Method/Constructor.pm b/lib/Moose/Meta/Method/Constructor.pm
index 73433f8..ed1fa1d 100644
--- a/lib/Moose/Meta/Method/Constructor.pm
+++ b/lib/Moose/Meta/Method/Constructor.pm
@@ -157,7 +157,7 @@ sub _generate_slot_initializer {
                         '$val'
                     );
                 }
-                push @source => $self->_generate_slot_assignment($attr, '$val');
+                push @source => $self->_generate_slot_assignment($attr, '$val', $index);
 
             push @source => "} else {";
         }
@@ -178,7 +178,7 @@ sub _generate_slot_initializer {
                 ('$type_constraints[' . $index . ']'),                
                 '$val'
             ) if ($is_moose && $attr->has_type_constraint);
-            push @source => $self->_generate_slot_assignment($attr, $default);
+            push @source => $self->_generate_slot_assignment($attr, $default, $index);
             push @source => '}'; # close - wrap this to avoid my $val overrite warnings           
 
         push @source => "}" if defined $attr->init_arg;
@@ -203,7 +203,7 @@ sub _generate_slot_initializer {
                     '$val'
                 );
             }
-            push @source => $self->_generate_slot_assignment($attr, '$val');
+            push @source => $self->_generate_slot_assignment($attr, '$val', $index);
 
         push @source => "}";
     }
@@ -212,16 +212,26 @@ sub _generate_slot_initializer {
 }
 
 sub _generate_slot_assignment {
-    my ($self, $attr, $value) = @_;
-    my $source = (
-        $self->meta_instance->inline_set_slot_value(
-            '$instance',
-            ("'" . $attr->name . "'"),
-            $value
-        ) . ';'
-    );
-
-    my $is_moose = $attr->isa('Moose::Meta::Attribute'); # XXX FIXME
+    my ($self, $attr, $value, $index) = @_;
+
+    my $source;
+    
+    if ($attr->has_initializer) {
+        $source = (
+            '$attrs->[' . $index . ']->set_initial_value($instance, ' . $value . ');'
+        );        
+    }
+    else {
+        $source = (
+            $self->meta_instance->inline_set_slot_value(
+                '$instance',
+                ("'" . $attr->name . "'"),
+                $value
+            ) . ';'
+        );        
+    }
+    
+    my $is_moose = $attr->isa('Moose::Meta::Attribute'); # XXX FIXME        
 
     if ($is_moose && $attr->is_weak_ref) {
         $source .= (
diff --git a/t/000_recipes/001_recipe.t b/t/000_recipes/001_recipe.t
index 91b877a..bdc56ef 100644
--- a/t/000_recipes/001_recipe.t
+++ b/t/000_recipes/001_recipe.t
@@ -23,7 +23,7 @@ BEGIN {
 	    $self->y(0);    
 	}
 	
-	__PACKAGE__->meta->make_immutable(debug => 0);
+	make_immutable(debug => 0);
 }{	
 	package Point3D;
 	use Moose;
@@ -37,7 +37,7 @@ BEGIN {
 	    $self->{z} = 0;
 	};
 	
-    __PACKAGE__->meta->make_immutable(debug => 0);
+    make_immutable(debug => 0);
 }
 
 my $point = Point->new(x => 1, y => 2);	
diff --git a/t/000_recipes/002_recipe.t b/t/000_recipes/002_recipe.t
index 4e0b571..cff422b 100644
--- a/t/000_recipes/002_recipe.t
+++ b/t/000_recipes/002_recipe.t
@@ -29,7 +29,7 @@ BEGIN {
         $self->balance($current_balance - $amount);
     }
     
-	__PACKAGE__->meta->make_immutable(debug => 0);
+	make_immutable(debug => 0);
 }{
 	package CheckingAccount;	
 	use Moose;
@@ -47,7 +47,7 @@ BEGIN {
 		}
 	};
 
-	__PACKAGE__->meta->make_immutable(debug => 0);
+	make_immutable(debug => 0);
 }
 
 my $savings_account = BankAccount->new(balance => 250);
diff --git a/t/000_recipes/003_recipe.t b/t/000_recipes/003_recipe.t
index cc7afbd..0e680d4 100644
--- a/t/000_recipes/003_recipe.t
+++ b/t/000_recipes/003_recipe.t
@@ -46,7 +46,7 @@ BEGIN {
 	    $tree->parent($self) if defined $tree;   
 	};
 	
-    __PACKAGE__->meta->make_immutable(debug => 0);	
+    make_immutable(debug => 0);	
 }
 
 my $root = BinaryTree->new(node => 'root');
diff --git a/t/000_recipes/004_recipe.t b/t/000_recipes/004_recipe.t
index 1f9bbc0..d7ddd98 100644
--- a/t/000_recipes/004_recipe.t
+++ b/t/000_recipes/004_recipe.t
@@ -45,7 +45,7 @@ BEGIN {
     has 'state'    => (is => 'rw', isa => 'USState');
     has 'zip_code' => (is => 'rw', isa => 'USZipCode');   
     
-    __PACKAGE__->meta->make_immutable(debug => 0);
+    make_immutable(debug => 0);
 }{
     
     package Company;
@@ -80,7 +80,7 @@ BEGIN {
         }
     };
     
-    __PACKAGE__->meta->make_immutable(debug => 0);
+    make_immutable(debug => 0);
 }{    
     
     package Person;
@@ -98,7 +98,7 @@ BEGIN {
                $self->last_name;
     }
 
-    __PACKAGE__->meta->make_immutable(debug => 0);
+    make_immutable(debug => 0);
 }{
       
     package Employee;
@@ -114,7 +114,7 @@ BEGIN {
         super() . ', ' . $self->title
     };
     
-    __PACKAGE__->meta->make_immutable(debug => 0);
+    make_immutable(debug => 0);
 }
 
 my $ii;
diff --git a/t/000_recipes/005_recipe.t b/t/000_recipes/005_recipe.t
index 7ea0371..f44acc8 100644
--- a/t/000_recipes/005_recipe.t
+++ b/t/000_recipes/005_recipe.t
@@ -62,7 +62,7 @@ BEGIN {
 	    default => sub { HTTP::Headers->new } 
     );
     
-    __PACKAGE__->meta->make_immutable(debug => 0);
+    make_immutable(debug => 0);
 }
 
 my $r = Request->new;
diff --git a/t/000_recipes/006_recipe.t b/t/000_recipes/006_recipe.t
index 5b8f9d2..0c1b8c9 100644
--- a/t/000_recipes/006_recipe.t
+++ b/t/000_recipes/006_recipe.t
@@ -81,7 +81,7 @@ BEGIN {
         sprintf '$%0.2f USD' => $self->amount
     }
     
-    __PACKAGE__->meta->make_immutable(debug => 0);
+    make_immutable(debug => 0);
 }
 
 ok(US::Currency->does('Comparable'), '... US::Currency does Comparable');
diff --git a/t/020_attributes/019_attribute_lazy_initializer.t b/t/020_attributes/019_attribute_lazy_initializer.t
index e139a34..ef6d0c8 100644
--- a/t/020_attributes/019_attribute_lazy_initializer.t
+++ b/t/020_attributes/019_attribute_lazy_initializer.t
@@ -3,7 +3,7 @@
 use strict;
 use warnings;
 
-use Test::More tests => 4;
+use Test::More tests => 21;
 use Test::Exception;
 
 BEGIN {
@@ -19,27 +19,113 @@ BEGIN {
         writer => 'set_foo',
         initializer => sub {
             my ($self, $value, $callback, $attr) = @_;
+            
+            ::isa_ok($attr, 'Moose::Meta::Attribute');
+            ::is($attr->name, 'foo', '... got the right name');
+            
             $callback->($value * 2);
         },
     );
 
     has 'lazy_foo' => (
-        reader  => 'get_lazy_foo',
-        default => 10,
+        reader      => 'get_lazy_foo',
+        lazy        => 1,
+        default     => 10,
         initializer => sub {
             my ($self, $value, $callback, $attr) = @_;
+            
+            ::isa_ok($attr, 'Moose::Meta::Attribute');
+            ::is($attr->name, 'lazy_foo', '... got the right name');            
+            
             $callback->($value * 2);
         },
     );
+    
+    has 'lazy_foo_w_type' => (
+        reader      => 'get_lazy_foo_w_type',
+        isa         => 'Int',
+        lazy        => 1,
+        default     => 20,
+        initializer => sub {
+            my ($self, $value, $callback, $attr) = @_;
+            
+            ::isa_ok($attr, 'Moose::Meta::Attribute');
+            ::is($attr->name, 'lazy_foo_w_type', '... got the right name');            
+            
+            $callback->($value * 2);
+        },
+    );   
+    
+    has 'lazy_foo_builder' => (
+        reader      => 'get_lazy_foo_builder',
+        builder     => 'get_foo_builder',
+        initializer => sub {
+            my ($self, $value, $callback, $attr) = @_;
+            
+            ::isa_ok($attr, 'Moose::Meta::Attribute');
+            ::is($attr->name, 'lazy_foo_builder', '... got the right name');            
+            
+            $callback->($value * 2);
+        },
+    );
+    
+    has 'lazy_foo_builder_w_type' => (
+        reader      => 'get_lazy_foo_builder_w_type',
+        builder     => 'get_foo_builder_w_type',
+        initializer => sub {
+            my ($self, $value, $callback, $attr) = @_;
+            
+            ::isa_ok($attr, 'Moose::Meta::Attribute');
+            ::is($attr->name, 'lazy_foo_builder_w_type', '... got the right name');            
+            
+            $callback->($value * 2);
+        },
+    );
+    
+    sub get_foo_builder        { 100  } 
+    sub get_foo_builder_w_type { 1000 }   
 }
 
 {
     my $foo = Foo->new(foo => 10);
     isa_ok($foo, 'Foo');
 
-    is($foo->get_foo,      20, 'initial value set to 2x given value');
-    is($foo->get_lazy_foo, 20, 'initial lazy value set to 2x given value');
+    is($foo->get_foo,             20, 'initial value set to 2x given value');
+    is($foo->get_lazy_foo,        20, 'initial lazy value set to 2x given value');
+    is($foo->get_lazy_foo_w_type, 40, 'initial lazy value with type set to 2x given value');
+    is($foo->get_lazy_foo_builder,        200, 'initial lazy value with builder set to 2x given value');
+    is($foo->get_lazy_foo_builder_w_type, 2000, 'initial lazy value with builder and type set to 2x given value');            
+}
+
+{
+    package Bar;
+    use Moose;
+    
+    has 'foo' => (
+        reader => 'get_foo',
+        writer => 'set_foo',
+        initializer => sub {
+            my ($self, $value, $callback, $attr) = @_;
+            
+            ::isa_ok($attr, 'Moose::Meta::Attribute');
+            ::is($attr->name, 'foo', '... got the right name');
+            
+            $callback->($value * 2);
+        },
+    );  
+    
+    make_immutable;
 }
 
+{
+    my $bar = Bar->new(foo => 10);
+    isa_ok($bar, 'Bar');
+
+    is($bar->get_foo, 20, 'initial value set to 2x given value');          
+}
+
+
+
+
 
 
diff --git a/t/030_roles/003_apply_role.t b/t/030_roles/003_apply_role.t
index 4be0dfa..f2adea8 100644
--- a/t/030_roles/003_apply_role.t
+++ b/t/030_roles/003_apply_role.t
@@ -39,7 +39,7 @@ BEGIN {
     sub boo { 'BarClass::boo' }
     sub foo { 'BarClass::foo' }  # << the role overrides this ...  
 
-    __PACKAGE__->meta->make_immutable(debug => 0);
+    make_immutable(debug => 0);
 }{
     
     package FooClass;
@@ -52,7 +52,7 @@ BEGIN {
 
     sub goo { 'FooClass::goo' }  # << overrides the one from the role ... 
     
-    __PACKAGE__->meta->make_immutable(debug => 0);
+    make_immutable(debug => 0);
 }{
     
     package FooBarClass;
diff --git a/t/060_compat/003_foreign_inheritence.t b/t/060_compat/003_foreign_inheritence.t
index f16ab06..81b2b0f 100644
--- a/t/060_compat/003_foreign_inheritence.t
+++ b/t/060_compat/003_foreign_inheritence.t
@@ -35,7 +35,7 @@ BEGIN {
 		return $class->meta->new_object('__INSTANCE__' => $super, @_);
 	}
 	
-	__PACKAGE__->meta->make_immutable(debug => 0);
+	make_immutable(debug => 0);
 
     package Bucket;
     use metaclass 'Class::MOP::Class';
diff --git a/t/300_immutable/002_apply_roles_to_immutable.t b/t/300_immutable/002_apply_roles_to_immutable.t
index e4e0c3e..cb86ed0 100644
--- a/t/300_immutable/002_apply_roles_to_immutable.t
+++ b/t/300_immutable/002_apply_roles_to_immutable.t
@@ -26,7 +26,7 @@ BEGIN {
     
     sub baz { 'Foo::baz' }
     
-	__PACKAGE__->meta->make_immutable(debug => 0);
+	make_immutable(debug => 0);
 }
 
 my $foo = Foo->new;