From: Stevan Little <stevan.little@iinteractive.com>
Date: Wed, 9 Jul 2008 20:58:02 +0000 (+0000)
Subject: fixing bug
X-Git-Tag: 0_55~50
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=d5598adee5228c5f03d24157cf23b3889637e1be;p=gitmo%2FMoose.git

fixing bug
---

diff --git a/Changes b/Changes
index ad3e7c3..0d8b305 100644
--- a/Changes
+++ b/Changes
@@ -7,6 +7,11 @@ Revision history for Perl extension Moose
         created so that the process can be more easily 
         overridden by subclasses (stevan)
 
+    * Moose::Meta::TypeConstraint
+      - fixing what is passed into a ->message with 
+        the type constraints (RT #37569)
+        - added tests for this (Charles Alderman)
+
 0.54 Thurs. July 3, 2008
     ... this is not my day today ...
     
diff --git a/lib/Moose/Meta/TypeConstraint.pm b/lib/Moose/Meta/TypeConstraint.pm
index 8ae760c..89b5b81 100644
--- a/lib/Moose/Meta/TypeConstraint.pm
+++ b/lib/Moose/Meta/TypeConstraint.pm
@@ -77,12 +77,12 @@ sub validate {
 
 sub get_message {
     my ($self, $value) = @_;
-    $value = (defined $value ? overload::StrVal($value) : 'undef');
     if (my $msg = $self->message) {
         local $_ = $value;
         return $msg->($value);
     }
     else {
+        $value = (defined $value ? overload::StrVal($value) : 'undef');        
         return "Validation failed for '" . $self->name . "' failed with value $value";
     }    
 }
diff --git a/t/100_bugs/017_type_constraint_messages.t b/t/100_bugs/017_type_constraint_messages.t
new file mode 100644
index 0000000..d425787
--- /dev/null
+++ b/t/100_bugs/017_type_constraint_messages.t
@@ -0,0 +1,70 @@
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More no_plan => 1;
+use Test::Exception;
+
+BEGIN {
+    use_ok('Moose');
+}
+
+# RT #37569
+
+{
+    package MyObject;
+    use Moose;
+
+    package Foo;
+    use Moose;
+    use Moose::Util::TypeConstraints;
+
+    subtype 'MyArrayRef'
+       => as 'ArrayRef'
+       => where { defined $_->[0] }
+       => message { ref $_ ? "ref: ". ref $_ : 'scalar' }  # stringy  
+    ;
+
+    subtype 'MyObjectType'
+       => as 'Object'
+       => where { $_->isa('MyObject') }
+       => message {
+          if ( $_->isa('SomeObject') ) {
+            return 'More detailed error message';
+          }
+          elsif ( blessed $_ ) {
+            return 'Well it is an object';
+          }
+          else {
+            return 'Doh!';
+          }
+       }
+    ;
+
+    type 'NewType'
+       => where { $_->isa('MyObject') }
+       => message { blessed $_ ? 'blessed' : 'scalar' }
+    ;
+
+    has 'obj' => ( is => 'rw', isa => 'MyObjectType' );
+    has 'ar'  => ( is => 'rw', isa => 'MyArrayRef' );
+    has 'nt'  => ( is => 'rw', isa => 'NewType' );
+}
+
+my $foo = Foo->new;
+my $obj = MyObject->new;
+
+throws_ok { 
+    $foo->ar([]);
+} qr/Attribute \(ar\) does not pass the type constraint because: ref: ARRAY/, '... got the right error message';
+
+throws_ok { 
+    $foo->obj($foo); # Doh!
+} qr/Attribute \(obj\) does not pass the type constraint because: Well it is an object/, '... got the right error message';
+
+throws_ok { 
+    $foo->nt($foo);  # scalar
+} qr/Attribute \(nt\) does not pass the type constraint because: blessed/, '... got the right error message';
+
+