From: Karen Etheridge <ether@cpan.org>
Date: Mon, 14 Mar 2011 22:21:43 +0000 (-0700)
Subject: do not use Undef-Tolerant behaviour on attributes that are capable of handling undef
X-Git-Tag: 0.10~7
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=3991a5d2d6058c15d85b028dae0c548922c38dbe;p=gitmo%2FMooseX-UndefTolerant.git

do not use Undef-Tolerant behaviour on attributes that are capable of handling undef
---

diff --git a/lib/MooseX/UndefTolerant/Attribute.pm b/lib/MooseX/UndefTolerant/Attribute.pm
index 15d35dd..aa8f5d1 100644
--- a/lib/MooseX/UndefTolerant/Attribute.pm
+++ b/lib/MooseX/UndefTolerant/Attribute.pm
@@ -5,13 +5,22 @@ around('initialize_instance_slot', sub {
     my $orig = shift;
     my $self = shift;
 
-    my $ia = $self->init_arg;
-
-    # $_[2] is the hashref of options passed to the constructor. If our
-    # parameter passed in was undef, pop it off the args...
-    pop unless (defined $ia && defined($_[2]->{$ia}));
-
-    # Invoke the real init, as the above line cleared the unef
+    my $key_name = $self->init_arg;
+
+    # $_[2] is the hashref of options passed to the constructor.
+    # If our parameter passed in was undef, pop it off the args...
+    # but leave the value unscathed if the attribute's type constraint can
+    # handle undef (or doesn't have one, which implicitly means it can)
+    if (not defined $key_name or not defined($_[2]->{$key_name}))
+    {
+        my $type_constraint = $self->type_constraint;
+        if ($type_constraint and not $type_constraint->check(undef))
+        {
+            pop;
+        }
+    }
+
+    # Invoke the real init, as the above line cleared the undef
     $self->$orig(@_)
 });
 
diff --git a/lib/MooseX/UndefTolerant/Constructor.pm b/lib/MooseX/UndefTolerant/Constructor.pm
index 2463bf2..969faca 100644
--- a/lib/MooseX/UndefTolerant/Constructor.pm
+++ b/lib/MooseX/UndefTolerant/Constructor.pm
@@ -12,18 +12,23 @@ if ( $Moose::VERSION < 1.9900 ) {
                 # insert a line of code at the start of the initializer,
                 # clearing the param if it's undefined.
 
-                if (defined $key_name) {
-                        my $tolerant_code =
-                             qq# delete \$params->{'$key_name'} unless # .
+                if (defined $key_name)
+                {
+                    # leave the value unscathed if the attribute's type constraint can
+                    # handle undef (or doesn't have one, which implicitly means it can)
+                    my $type_constraint = $self->_attributes->[$_[0]]->type_constraint;
+                    if ($type_constraint and not $type_constraint->check(undef))
+                    {
+                        my $tolerant_code = 
+                             qq# delete \$params->{'$key_name'} unless # . 
                              qq# exists \$params->{'$key_name'} && defined \$params->{'$key_name'};\n#;
 
                         return $tolerant_code . $self->$orig(@_);
+                    }
                 }
-                else {
-                        return $self->$orig(@_);
-                }
-        });
-}
+
+                return $self->$orig(@_);
+});
 
 no Moose::Role;
 
diff --git a/t/constructor.t b/t/constructor.t
index ca51315..e97766e 100644
--- a/t/constructor.t
+++ b/t/constructor.t
@@ -1,4 +1,5 @@
-use Test::More;
+#use Test::More;
+use Test::Most 'die';
 use Test::Fatal;
 
 {
@@ -11,12 +12,16 @@ use Test::Fatal;
         isa => 'Num',
         predicate => 'has_attr1',
     );
-
     has 'attr2' => (
         is => 'ro',
         isa => 'Num',
         predicate => 'has_attr2',
     );
+    has 'attr3' => (
+        is => 'ro',
+        isa => 'Maybe[Num]',
+        predicate => 'has_attr3',
+    );
 }
 
 {
@@ -34,6 +39,11 @@ use Test::Fatal;
         isa => 'Num',
         predicate => 'has_attr2',
     );
+    has 'attr3' => (
+        is => 'ro',
+        isa => 'Maybe[Num]',
+        predicate => 'has_attr3',
+    );
 }
 
 package main;
@@ -45,21 +55,30 @@ sub do_tests
         my $obj = Foo->new;
         ok(!$obj->has_attr1, 'attr1 has no value before it is assigned');
         ok(!$obj->has_attr2, 'attr2 has no value before it is assigned');
+        ok(!$obj->has_attr3, 'attr3 has no value before it is assigned');
     }
 
     {
         my $obj = Foo->new(attr1 => undef);
         ok(!$obj->has_attr1, 'UT attr1 has no value when assigned undef in constructor');
-        is (exception { $obj = Foo->new(attr2 => undef) }, undef,
+        isnt (exception { $obj = Foo->new(attr2 => undef) }, undef,
             'But assigning undef to attr2 generates a type constraint error');
+
+        is (exception { $obj = Foo->new(attr3 => undef) }, undef,
+            'assigning undef to attr3 is acceptable');
+        ok($obj->has_attr3, 'attr3 retains its undef value when assigned undef in constructor');
     }
 
     {
-        my $obj = Foo->new(attr1 => 1234, attr2 => 5678);
+        my $obj = Foo->new(attr1 => 1234, attr2 => 5678, attr3 => 9012);
         is($obj->attr1, 1234, 'assigning a defined value during construction works as normal');
         ok($obj->has_attr1, '...and the predicate returns true as normal');
+
         is($obj->attr2, 5678, 'assigning a defined value during construction works as normal');
         ok($obj->has_attr2, '...and the predicate returns true as normal');
+
+        is($obj->attr3, 9012, 'assigning a defined value during construction works as normal');
+        ok($obj->has_attr3, '...and the predicate returns true as normal');
     }
 
 
@@ -68,20 +87,33 @@ sub do_tests
     {
         my $obj = Bar->new;
         ok(!$obj->has_attr1, 'attr1 has no value before it is assigned');
+        ok(!$obj->has_attr2, 'attr2 has no value before it is assigned');
+        ok(!$obj->has_attr3, 'attr3 has no value before it is assigned');
     }
 
     {
         my $obj = Bar->new(attr1 => undef);
         ok(!$obj->has_attr1, 'attr1 has no value when assigned undef in constructor');
+        # note this test differs from the Foo case above
         is (exception { $obj = Bar->new(attr2 => undef) }, undef,
             'assigning undef to attr2 does not produce an error');
         ok(!$obj->has_attr2, 'attr2 has no value when assigned undef in constructor');
+
+        is( exception { $obj = Foo->new(attr3 => undef) }, undef,
+            'assigning undef to attr3 is acceptable');
+        ok($obj->has_attr3, 'attr3 retains its undef value when assigned undef in constructor');
     }
 
     {
-        my $obj = Bar->new(attr1 => 1234);
+        my $obj = Bar->new(attr1 => 1234, attr2 => 5678, attr3 => 9012);
         is($obj->attr1, 1234, 'assigning a defined value during construction works as normal');
         ok($obj->has_attr1, '...and the predicate returns true as normal');
+
+        is($obj->attr2, 5678, 'assigning a defined value during construction works as normal');
+        ok($obj->has_attr2, '...and the predicate returns true as normal');
+
+        is($obj->attr3, 9012, 'assigning a defined value during construction works as normal');
+        ok($obj->has_attr3, '...and the predicate returns true as normal');
     }
 }
 
diff --git a/t/defaults.t b/t/defaults.t
index 6e29950..2ae2c76 100644
--- a/t/defaults.t
+++ b/t/defaults.t
@@ -1,4 +1,5 @@
-use Test::More;
+#use Test::More;
+use Test::Most 'die';
 use Test::Fatal;
 
 use MooseX::UndefTolerant::Attribute ();
@@ -20,6 +21,12 @@ use MooseX::UndefTolerant::Attribute ();
         predicate => 'has_attr2',
         default => 2,
     );
+    has 'attr3' => (
+        is => 'ro',
+        isa => 'Maybe[Num]',
+        predicate => 'has_attr3',
+        default => 3,
+    );
 }
 
 {
@@ -39,6 +46,12 @@ use MooseX::UndefTolerant::Attribute ();
         predicate => 'has_attr2',
         default => 2,
     );
+    has 'attr3' => (
+        is => 'ro',
+        isa => 'Maybe[Num]',
+        predicate => 'has_attr3',
+        default => 3,
+    );
 }
 
 
@@ -62,23 +75,33 @@ sub do_tests_with_class
         my $obj = $class->new;
         ok($obj->has_attr1, 'attr1 has a value');
         ok($obj->has_attr2, 'attr2 has a value');
+        ok($obj->has_attr3, 'attr3 has a value');
+
         is($obj->attr1, 1, 'attr1\'s value is its default');
         is($obj->attr2, 2, 'attr2\'s value is its default');
+        is($obj->attr3, 3, 'attr3\'s value is its default');
     }
 
     {
-        my $obj = $class->new(attr1 => undef);
+        my $obj = $class->new(attr1 => undef, attr3 => undef);
         ok($obj->has_attr1, 'UT attr1 has a value when assigned undef in constructor');
+        ok($obj->has_attr3, 'attr3 retains its undef value when assigned undef in constructor');
+
         is($obj->attr1, 1, 'attr1\'s value is its default');
         is($obj->attr2, 2, 'attr2\'s value is its default');
+        is($obj->attr3, undef, 'attr3\'s value is not its default (explicitly set)');
     }
 
     {
-        my $obj = $class->new(attr1 => 1234, attr2 => 5678);
+        my $obj = $class->new(attr1 => 1234, attr2 => 5678, attr3 => 9012);
         is($obj->attr1, 1234, 'assigning a defined value during construction works as normal');
         ok($obj->has_attr1, '...and the predicate returns true as normal');
+
         is($obj->attr2, 5678, 'assigning a defined value during construction works as normal');
         ok($obj->has_attr2, '...and the predicate returns true as normal');
+
+        is($obj->attr3, 9012, 'assigning a defined value during construction works as normal');
+        ok($obj->has_attr3, '...and the predicate returns true as normal');
     }
 }