[libtype-tiny-perl] 12/46: fix weird list/scalar context thing - I don't quite understand it myself but it appears to be the root cause of RT#98159

[Jonas Smedegaard]

This is an automated email from the git hooks/post-receive script.

js pushed a commit to tag 1.001_000
in repository libtype-tiny-perl.

commit 9accc7d74dc37b5bc1caa9226d8b8763fb1cf058
Author: Toby Inkster <mail at tobyinkster.co.uk>
Date:   Fri Aug 29 10:43:49 2014 +0100

    fix weird list/scalar context thing - I don't quite understand it myself but it appears to be the root cause of RT#98159
---
 lib/Type/Coercion.pm                             |  8 ++++----
 t/30-integration/Moose/native-attribute-traits.t | 25 +++++++++++++++++++++---
 2 files changed, 26 insertions(+), 7 deletions(-)

diff --git a/lib/Type/Coercion.pm b/lib/Type/Coercion.pm
index 49c116a..7ac3c89 100644
--- a/lib/Type/Coercion.pm
+++ b/lib/Type/Coercion.pm
@@ -283,8 +283,8 @@ sub _build_compiled_coercion
 			!defined($codes[$i])
 				? sprintf('  { return $_[0] }') :
 			Types::TypeTiny::StringLike->check($codes[$i])
-				? sprintf('  { local $_ = $_[0]; return( %s ) }', $codes[$i]) :
-			sprintf('  { local $_ = $_[0]; return $codes[%d]->(@_) }', $i);
+				? sprintf('  { local $_ = $_[0]; return scalar(%s); }', $codes[$i]) :
+			sprintf('  { local $_ = $_[0]; return scalar($codes[%d]->(@_)) }', $i);
 	}
 	
 	push @sub, 'return $_[0];';
@@ -366,9 +366,9 @@ sub inline_coercion
 		push @sub, sprintf('(%s) ?', $types[$i]->inline_check($varname));
 		push @sub,
 			(defined($codes[$i]) && ($varname eq '$_'))
-				? sprintf('scalar(%s) :', $codes[$i]) :
+				? sprintf('scalar(do { %s }) :', $codes[$i]) :
 			defined($codes[$i])
-				? sprintf('do { local $_ = %s; scalar(%s) } :', $varname, $codes[$i]) :
+				? sprintf('scalar(do { local $_ = %s; %s }) :', $varname, $codes[$i]) :
 			sprintf('%s :', $varname);
 	}
 	
diff --git a/t/30-integration/Moose/native-attribute-traits.t b/t/30-integration/Moose/native-attribute-traits.t
index c1d4d11..d88c37b 100644
--- a/t/30-integration/Moose/native-attribute-traits.t
+++ b/t/30-integration/Moose/native-attribute-traits.t
@@ -85,7 +85,9 @@ my %attributes = (
 		$class->$next(@_);
 	}
 }
-my $minimilk = (InstanceOf['Mini::Milk'])->plus_constructors(Num, 'new');
+
+my $minimilk = InstanceOf->of('Mini::Milk')->plus_constructors(Num, "new");
+
 {
 	package MyCollection2;
 	use Moose;
@@ -165,6 +167,21 @@ my $minimilk = (InstanceOf['Mini::Milk'])->plus_constructors(Num, 'new');
 	);
 }
 
+WEIRD_ERROR: {
+	my $c = MyCollection3
+		->meta
+		->get_attribute('things')
+		->type_constraint
+		->coercion
+		->compiled_coercion;
+	
+	my $input     = [ Mini::Milk->new(0), 1, 2, 3 ];
+	my $output   = $c->($input);
+	my $expected = [ map Mini::Milk->new($_), 0..3 ];
+	is_deeply($output, $expected)
+		or diag( B::Deparse->new->coderef2text($c) );
+}
+
 my $i = 0;
 with_immutable
 {
@@ -188,7 +205,7 @@ with_immutable
 			'pushing not ok value',
 		);
 	};
-	
+
 	my %subtests = (
 		MyCollection2  => "Array trait with type ArrayRef[InstanceOf] and coercion",
 		MyCollection3  => "Array trait with type ArrayRef[InstanceOf] and coercion and subtyping",
@@ -198,7 +215,7 @@ with_immutable
 		subtest $subtests{$class} => sub
 		{
 			my $coll = $class->new(things => []);
-
+			
 			is(
 				exception {
 					$coll->add( 'Mini::Milk'->new(i => 0) );
@@ -301,6 +318,8 @@ with_immutable
 	}
 } qw(
 	MyCollection
+	MyCollection2
+	MyCollection3
 	MyHashes
 	Mini::Milk
 );

-- 
Alioth's /usr/local/bin/git-commit-notice on /srv/git.debian.org/git/pkg-perl/packages/libtype-tiny-perl.git