From: Stevan Little <stevan.little@iinteractive.com>
Date: Sun, 26 Mar 2006 02:21:38 +0000 (+0000)
Subject: uploadin
X-Git-Tag: 0_05~59
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=ca01a97b9e3064340ddad5cffae1c48a07ba9108;p=gitmo%2FMoose.git

uploadin
---

diff --git a/lib/Moose/Meta/Attribute.pm b/lib/Moose/Meta/Attribute.pm
index 2430aec..005e323 100644
--- a/lib/Moose/Meta/Attribute.pm
+++ b/lib/Moose/Meta/Attribute.pm
@@ -11,6 +11,8 @@ our $VERSION = '0.02';
 
 use base 'Class::MOP::Attribute';
 
+__PACKAGE__->meta->add_attribute('required' => (reader => 'is_required'  ));
+__PACKAGE__->meta->add_attribute('lazy'     => (reader => 'is_lazy'      ));
 __PACKAGE__->meta->add_attribute('coerce'   => (reader => 'should_coerce'));
 __PACKAGE__->meta->add_attribute('weak_ref' => (reader => 'is_weak_ref'  ));
 __PACKAGE__->meta->add_attribute('type_constraint' => (
@@ -25,120 +27,83 @@ __PACKAGE__->meta->add_before_method_modifier('new' => sub {
 	        || confess "You cannot have coercion without specifying a type constraint";
         confess "You cannot have a weak reference to a coerced value"
             if $options{weak_ref};	        
-	}		
+	}	
+	if (exists $options{lazy} && $options{lazy}) {
+	    (exists $options{default})
+	        || confess "You cannot have lazy attribute without specifying a default value for it";	    
+	}	
 });
 
 sub generate_accessor_method {
     my ($self, $attr_name) = @_;
-	if ($self->has_type_constraint) {
-		if ($self->is_weak_ref) {
-		    return sub {
-				if (scalar(@_) == 2) {
-					(defined $self->type_constraint->check($_[1]))
-						|| confess "Attribute ($attr_name) does not pass the type contraint with '$_[1]'"
-							if defined $_[1];
-			        $_[0]->{$attr_name} = $_[1];
-					weaken($_[0]->{$attr_name});
-				}
-		        $_[0]->{$attr_name};
-		    };			
-		}
-		else {
-		    if ($self->should_coerce) {
-    		    return sub {
-    				if (scalar(@_) == 2) {
-    				    my $val = $self->type_constraint->coercion->coerce($_[1]);
-    					(defined $self->type_constraint->check($val))
-    						|| confess "Attribute ($attr_name) does not pass the type contraint with '$val'"
-    							if defined $val;
-    			        $_[0]->{$attr_name} = $val;
-    				}
-    		        $_[0]->{$attr_name};
-    		    };		        
-		    }
-		    else {
-    		    return sub {
-    				if (scalar(@_) == 2) {
-    					(defined $self->type_constraint->check($_[1]))
-    						|| confess "Attribute ($attr_name) does not pass the type contraint with '$_[1]'"
-    							if defined $_[1];
-    			        $_[0]->{$attr_name} = $_[1];
-    				}
-    		        $_[0]->{$attr_name};
-    		    };
-		    }	
-		}	
-	}
-	else {
-		if ($self->is_weak_ref) {
-		    return sub {
-				if (scalar(@_) == 2) {
-			        $_[0]->{$attr_name} = $_[1];
-					weaken($_[0]->{$attr_name});
-				}
-		        $_[0]->{$attr_name};
-		    };			
-		}
-		else {		
-		    sub {
-			    $_[0]->{$attr_name} = $_[1] if scalar(@_) == 2;
-		        $_[0]->{$attr_name};
-		    };		
-		}
-	}
+    my $value_name = $self->should_coerce ? '$val' : '$_[1]';
+    my $code = 'sub { '
+    . 'if (scalar(@_) == 2) {'
+        . ($self->is_required ? 
+            'defined($_[1]) || confess "Attribute ($attr_name) is required, so cannot be set to undef";' 
+            : '')
+        . ($self->should_coerce ? 
+            'my $val = $self->type_constraint->coercion->coerce($_[1]);'
+            : '')
+        . ($self->has_type_constraint ? 
+            ('(defined $self->type_constraint->check(' . $value_name . '))'
+            	. '|| confess "Attribute ($attr_name) does not pass the type contraint with \'' . $value_name . '\'"'
+            		. 'if defined ' . $value_name . ';')
+            : '')
+        . '$_[0]->{$attr_name} = ' . $value_name . ';'
+        . ($self->is_weak_ref ?
+            'weaken($_[0]->{$attr_name});'
+            : '')
+    . ' }'
+    . ($self->is_lazy ? 
+            '$_[0]->{$attr_name} = ($self->has_default ? $self->default($_[0]) : undef)'
+            . 'unless exists $_[0]->{$attr_name};'
+            : '')    
+    . ' $_[0]->{$attr_name};'
+    . ' }';
+    my $sub = eval $code;
+    confess "Could not create writer for '$attr_name' because $@ \n code: $code" if $@;
+    return $sub;    
 }
 
 sub generate_writer_method {
     my ($self, $attr_name) = @_; 
-	if ($self->has_type_constraint) {
-		if ($self->is_weak_ref) {
-		    return sub { 
-				(defined $self->type_constraint->check($_[1]))
-					|| confess "Attribute ($attr_name) does not pass the type contraint with '$_[1]'"
-						if defined $_[1];
-				$_[0]->{$attr_name} = $_[1];
-				weaken($_[0]->{$attr_name});
-			};
-		}
-		else {
-		    if ($self->should_coerce) {	
-    		    return sub { 
-    		        my $val = $self->type_constraint->coercion->coerce($_[1]);
-    				(defined $self->type_constraint->check($val))
-    					|| confess "Attribute ($attr_name) does not pass the type contraint with '$val'"
-    						if defined $val;
-    				$_[0]->{$attr_name} = $val;
-    			};		        
-		    }
-		    else {	    
-    		    return sub { 
-    				(defined $self->type_constraint->check($_[1]))
-    					|| confess "Attribute ($attr_name) does not pass the type contraint with '$_[1]'"
-    						if defined $_[1];
-    				$_[0]->{$attr_name} = $_[1];
-    			};	
-    		}		
-		}
-	}
-	else {
-		if ($self->is_weak_ref) {
-		    return sub { 
-				$_[0]->{$attr_name} = $_[1];
-				weaken($_[0]->{$attr_name});
-			};			
-		}
-		else {
-		    return sub { $_[0]->{$attr_name} = $_[1] };			
-		}
-	}
+    my $value_name = $self->should_coerce ? '$val' : '$_[1]';
+    my $code = 'sub { '
+    . ($self->is_required ? 
+        'defined($_[1]) || confess "Attribute ($attr_name) is required, so cannot be set to undef";' 
+        : '')
+    . ($self->should_coerce ? 
+        'my $val = $self->type_constraint->coercion->coerce($_[1]);'
+        : '')
+    . ($self->has_type_constraint ? 
+        ('(defined $self->type_constraint->check(' . $value_name . '))'
+        	. '|| confess "Attribute ($attr_name) does not pass the type contraint with \'' . $value_name . '\'"'
+        		. 'if defined ' . $value_name . ';')
+        : '')
+    . '$_[0]->{$attr_name} = ' . $value_name . ';'
+    . ($self->is_weak_ref ?
+        'weaken($_[0]->{$attr_name});'
+        : '')
+    . ' }';
+    my $sub = eval $code;
+    confess "Could not create writer for '$attr_name' because $@ \n code: $code" if $@;
+    return $sub;    
 }
 
 sub generate_reader_method {
     my ($self, $attr_name) = @_; 
-    sub { 
-        confess "Cannot assign a value to a read-only accessor" if @_ > 1;
-        $_[0]->{$attr_name} 
-    };   
+    my $code = 'sub {'
+    . 'confess "Cannot assign a value to a read-only accessor" if @_ > 1;'
+    . ($self->is_lazy ? 
+            '$_[0]->{$attr_name} = ($self->has_default ? $self->default($_[0]) : undef)'
+            . 'unless exists $_[0]->{$attr_name};'
+            : '')
+    . '$_[0]->{$attr_name};'
+    . '}';
+    my $sub = eval $code;
+    confess "Could not create reader for '$attr_name' because $@ \n code: $code" if $@;
+    return $sub;
 }
 
 1;
@@ -202,6 +167,16 @@ for L<Moose::Meta::TypeConstraint>.
 
 Returns true of this meta-attribute produces a weak reference.
 
+=item B<is_required>
+
+Returns true of this meta-attribute is required to have a value.
+
+=item B<is_lazy>
+
+Returns true of this meta-attribute should be initialized lazily.
+
+NOTE: lazy attributes, B<must> have a C<default> field set.
+
 =item B<should_coerce>
 
 Returns true of this meta-attribute should perform type coercion.
diff --git a/lib/Moose/Meta/Class.pm b/lib/Moose/Meta/Class.pm
index 5d2d046..addebf3 100644
--- a/lib/Moose/Meta/Class.pm
+++ b/lib/Moose/Meta/Class.pm
@@ -18,7 +18,16 @@ sub construct_instance {
         my $init_arg = $attr->init_arg();
         # try to fetch the init arg from the %params ...
         my $val;        
-        $val = $params{$init_arg} if exists $params{$init_arg};
+        if (exists $params{$init_arg}) {
+            $val = $params{$init_arg};
+        }
+        else {
+            # skip it if it's lazy
+            next if $attr->is_lazy;
+            # and die if it is required            
+            confess "Attribute (" . $attr->name . ") is required" 
+                if $attr->is_required
+        }
         # if nothing was in the %params, we can use the 
         # attribute's default value (if it has one)
         if (!defined $val && $attr->has_default) {
diff --git a/t/030_attribute_reader_generation.t b/t/030_attribute_reader_generation.t
new file mode 100644
index 0000000..b16f797
--- /dev/null
+++ b/t/030_attribute_reader_generation.t
@@ -0,0 +1,64 @@
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 14;
+use Test::Exception;
+
+BEGIN {
+    use_ok('Moose');           
+}
+
+{
+    package Foo;
+    use strict;
+    use warnings;
+    use Moose;
+    
+    eval {
+        has 'foo' => (
+            reader => 'get_foo'
+        );
+    };
+    ::ok(!$@, '... created the reader method okay');
+    
+    eval {
+        has 'lazy_foo' => (
+            reader => 'get_lazy_foo', 
+            lazy => 1, 
+            default => sub { 10 }
+        );
+    };
+    ::ok(!$@, '... created the lazy reader method okay');    
+}
+
+{
+    my $foo = Foo->new;
+    isa_ok($foo, 'Foo');
+
+    can_ok($foo, 'get_foo');
+    is($foo->get_foo(), undef, '... got an undefined value');
+    dies_ok {
+        $foo->get_foo(100);
+    } '... get_foo is a read-only';
+    
+    ok(!exists($foo->{lazy_foo}), '... no value in get_lazy_foo slot');
+    
+    can_ok($foo, 'get_lazy_foo');
+    is($foo->get_lazy_foo(), 10, '... got an deferred value');
+    dies_ok {
+        $foo->get_lazy_foo(100);
+    } '... get_lazy_foo is a read-only';    
+}
+
+{
+    my $foo = Foo->new(foo => 10, lazy_foo => 100);
+    isa_ok($foo, 'Foo');
+
+    is($foo->get_foo(), 10, '... got the correct value');
+    is($foo->get_lazy_foo(), 100, '... got the correct value');    
+}
+
+
+
diff --git a/t/031_attribute_writer_generation.t b/t/031_attribute_writer_generation.t
new file mode 100644
index 0000000..a76bf49
--- /dev/null
+++ b/t/031_attribute_writer_generation.t
@@ -0,0 +1,121 @@
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 29;
+use Test::Exception;
+
+use Scalar::Util 'isweak';
+
+BEGIN {
+    use_ok('Moose');           
+}
+
+{
+    package Foo;
+    use strict;
+    use warnings;
+    use Moose;
+    
+    eval {
+        has 'foo' => (
+            reader => 'get_foo',
+            writer => 'set_foo',
+        );
+    };
+    ::ok(!$@, '... created the writer method okay');
+
+    eval {
+        has 'foo_required' => (
+            reader   => 'get_foo_required',
+            writer   => 'set_foo_required',
+            required => 1,
+        );
+    };
+    ::ok(!$@, '... created the required writer method okay');
+
+    eval {
+        has 'foo_int' => (
+            reader => 'get_foo_int',
+            writer => 'set_foo_int',
+            isa    => 'Int',
+        );
+    };
+    ::ok(!$@, '... created the writer method with type constraint okay');    
+    
+    eval {
+        has 'foo_weak' => (
+            reader   => 'get_foo_weak',
+            writer   => 'set_foo_weak',
+            weak_ref => 1
+        );
+    };
+    ::ok(!$@, '... created the writer method with weak_ref okay');    
+}
+
+{
+    my $foo = Foo->new(foo_required => 'required');
+    isa_ok($foo, 'Foo');
+
+    # regular writer
+
+    can_ok($foo, 'set_foo');
+    is($foo->get_foo(), undef, '... got an unset value');
+    lives_ok {
+        $foo->set_foo(100);
+    } '... set_foo wrote successfully';
+    is($foo->get_foo(), 100, '... got the correct set value');   
+    
+    ok(!isweak($foo->{foo}), '... it is not a weak reference');             
+    
+    # required writer
+    
+    dies_ok {
+        Foo->new;
+    } '... cannot create without the required attribute';
+
+    can_ok($foo, 'set_foo_required');
+    is($foo->get_foo_required(), 'required', '... got an unset value');
+    lives_ok {
+        $foo->set_foo_required(100);
+    } '... set_foo_required wrote successfully';
+    is($foo->get_foo_required(), 100, '... got the correct set value');    
+    
+    dies_ok {
+        $foo->set_foo_required(undef);
+    } '... set_foo_required died successfully';    
+
+    ok(!isweak($foo->{foo_required}), '... it is not a weak reference');        
+    
+    # with type constraint
+    
+    can_ok($foo, 'set_foo_int');
+    is($foo->get_foo_int(), undef, '... got an unset value');
+    lives_ok {
+        $foo->set_foo_int(100);
+    } '... set_foo_int wrote successfully';
+    is($foo->get_foo_int(), 100, '... got the correct set value'); 
+    
+    dies_ok {
+        $foo->set_foo_int("Foo");
+    } '... set_foo_int died successfully';   
+        
+    ok(!isweak($foo->{foo_int}), '... it is not a weak reference');        
+        
+    # with weak_ref
+    
+    my $test = [];
+    
+    can_ok($foo, 'set_foo_weak');
+    is($foo->get_foo_weak(), undef, '... got an unset value');
+    lives_ok {
+        $foo->set_foo_weak($test);
+    } '... set_foo_weak wrote successfully';
+    is($foo->get_foo_weak(), $test, '... got the correct set value'); 
+    
+    ok(isweak($foo->{foo_weak}), '... it is a weak reference');
+}
+
+
+
diff --git a/t/032_attribute_accessor_generation.t b/t/032_attribute_accessor_generation.t
new file mode 100644
index 0000000..385134d
--- /dev/null
+++ b/t/032_attribute_accessor_generation.t
@@ -0,0 +1,135 @@
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 33;
+use Test::Exception;
+
+use Scalar::Util 'isweak';
+
+BEGIN {
+    use_ok('Moose');           
+}
+
+{
+    package Foo;
+    use strict;
+    use warnings;
+    use Moose;
+    
+    eval {
+        has 'foo' => (
+            accessor => 'foo',
+        );
+    };
+    ::ok(!$@, '... created the accessor method okay');
+    
+    eval {
+        has 'lazy_foo' => (
+            accessor => 'lazy_foo', 
+            lazy     => 1, 
+            default  => sub { 10 }
+        );
+    };
+    ::ok(!$@, '... created the lazy accessor method okay');              
+    
+
+    eval {
+        has 'foo_required' => (
+            accessor => 'foo_required',
+            required => 1,
+        );
+    };
+    ::ok(!$@, '... created the required accessor method okay');
+
+    eval {
+        has 'foo_int' => (
+            accessor => 'foo_int',
+            isa      => 'Int',
+        );
+    };
+    ::ok(!$@, '... created the accessor method with type constraint okay');    
+    
+    eval {
+        has 'foo_weak' => (
+            accessor => 'foo_weak',
+            weak_ref => 1
+        );
+    };
+    ::ok(!$@, '... created the accessor method with weak_ref okay');    
+}
+
+{
+    my $foo = Foo->new(foo_required => 'required');
+    isa_ok($foo, 'Foo');
+
+    # regular accessor
+
+    can_ok($foo, 'foo');
+    is($foo->foo(), undef, '... got an unset value');
+    lives_ok {
+        $foo->foo(100);
+    } '... foo wrote successfully';
+    is($foo->foo(), 100, '... got the correct set value');   
+    
+    ok(!isweak($foo->{foo}), '... it is not a weak reference');   
+    
+    # required writer
+    
+    dies_ok {
+        Foo->new;
+    } '... cannot create without the required attribute';
+
+    can_ok($foo, 'foo_required');
+    is($foo->foo_required(), 'required', '... got an unset value');
+    lives_ok {
+        $foo->foo_required(100);
+    } '... foo_required wrote successfully';
+    is($foo->foo_required(), 100, '... got the correct set value');    
+    
+    dies_ok {
+        $foo->foo_required(undef);
+    } '... foo_required died successfully';    
+
+    ok(!isweak($foo->{foo_required}), '... it is not a weak reference'); 
+    
+    # lazy
+    
+    ok(!exists($foo->{lazy_foo}), '... no value in lazy_foo slot');
+    
+    can_ok($foo, 'lazy_foo');
+    is($foo->lazy_foo(), 10, '... got an deferred value');        
+    
+    # with type constraint
+    
+    can_ok($foo, 'foo_int');
+    is($foo->foo_int(), undef, '... got an unset value');
+    lives_ok {
+        $foo->foo_int(100);
+    } '... foo_int wrote successfully';
+    is($foo->foo_int(), 100, '... got the correct set value'); 
+    
+    dies_ok {
+        $foo->foo_int("Foo");
+    } '... foo_int died successfully';   
+        
+    ok(!isweak($foo->{foo_int}), '... it is not a weak reference');        
+        
+    # with weak_ref
+    
+    my $test = [];
+    
+    can_ok($foo, 'foo_weak');
+    is($foo->foo_weak(), undef, '... got an unset value');
+    lives_ok {
+        $foo->foo_weak($test);
+    } '... foo_weak wrote successfully';
+    is($foo->foo_weak(), $test, '... got the correct set value'); 
+    
+    ok(isweak($foo->{foo_weak}), '... it is a weak reference');
+
+}
+
+
+