[libtype-tiny-perl] 28/46: initial implementation for compile_named and validate_named (still needs to be documented)

Jonas Smedegaard dr at jones.dk
Fri Sep 12 18:48:04 UTC 2014


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 a4ec1c6f42283dad28388e568ca8a2711b52ca97
Author: Toby Inkster <mail at tobyinkster.co.uk>
Date:   Sun Sep 7 13:42:53 2014 +0100

    initial implementation for compile_named and validate_named (still needs to be documented)
---
 lib/Type/Params.pm                    | 157 ++++++++++++++++-
 t/20-unit/Type-Params/compile-named.t | 311 ++++++++++++++++++++++++++++++++++
 2 files changed, 465 insertions(+), 3 deletions(-)

diff --git a/lib/Type/Params.pm b/lib/Type/Params.pm
index 020a902..b59c412 100644
--- a/lib/Type/Params.pm
+++ b/lib/Type/Params.pm
@@ -26,8 +26,8 @@ use Types::TypeTiny qw(CodeLike ArrayLike to_TypeTiny);
 require Exporter::Tiny;
 our @ISA = 'Exporter::Tiny';
 
-our @EXPORT = qw( compile );
-our @EXPORT_OK = qw( multisig validate Invocant );
+our @EXPORT    = qw( compile compile_named );
+our @EXPORT_OK = qw( multisig validate validate_named Invocant );
 
 BEGIN {
 	my $Invocant = 'Type::Tiny::Union'->new(
@@ -222,11 +222,162 @@ sub compile
 	return $closure;
 }
 
+sub compile_named
+{
+	my (@code, %env);
+	
+	@code = 'my (%R, %tmp, $tmp);';
+	push @code, '#placeholder';   # $code[1]
+	
+	my %options    = (ref($_[0]) eq "HASH" && !$_[0]{slurpy}) ? %{+shift} : ();
+	my $arg = -1;
+	my $had_slurpy;
+	
+	push @code, 'my %in = ((@_==1) && ref($_[0]) eq "HASH") ? %{$_[0]} : (@_ % 2) ? "Error::TypeTiny::WrongNumberOfParameters"->throw(message => "Odd number of elements in hash") : @_;';
+	
+	while (@_) {
+		++$arg;
+		my ($name, $constraint) = splice(@_, 0, 2);
+		
+		my $is_optional;
+		my $really_optional;
+		my $is_slurpy;
+		my $varname;
+		
+		if (Bool->check($constraint))
+		{
+			$constraint = $constraint ? Any : Optional[Any];
+		}
+		
+		if (HashRef->check($constraint))
+		{
+			$constraint = to_TypeTiny($constraint->{slurpy});
+			++$is_slurpy;
+			++$had_slurpy;
+		}
+		else
+		{
+			$is_optional     = grep $_->{uniq} == Optional->{uniq}, $constraint->parents;
+			$really_optional = $is_optional && $constraint->parent->{uniq} eq Optional->{uniq} && $constraint->type_parameter;
+			
+			$constraint = $constraint->type_parameter if $really_optional;
+		}
+		
+		unless ($is_optional or $is_slurpy) {
+			push @code, sprintf(
+				'exists($in{%s}) or "Error::TypeTiny::WrongNumberOfParameters"->throw(message => sprintf "Missing required parameter: %%s", %s);',
+				B::perlstring($name),
+				B::perlstring($name),
+			);
+		}
+		
+		my $need_to_close_if = 0;
+		
+		if ($is_slurpy) {
+			$varname = '\\%in';
+		}
+		elsif ($is_optional) {
+			push @code, sprintf('if (exists($in{%s})) {', B::perlstring($name));
+			push @code, sprintf('$tmp = delete($in{%s});', B::perlstring($name));
+			$varname = '$tmp';
+			++$need_to_close_if;
+		}
+		else {
+			push @code, sprintf('$tmp = delete($in{%s});', B::perlstring($name));
+			$varname = '$tmp';
+		}
+		
+		if ($constraint->has_coercion) {
+			if ($constraint->coercion->can_be_inlined) {
+				push @code, sprintf(
+					'$tmp = %s;',
+					$constraint->coercion->inline_coercion($varname)
+				);
+			}
+			else {
+				$env{'@coerce'}[$arg] = $constraint->coercion->compiled_coercion;
+				push @code, sprintf(
+					'$tmp = $coerce[%d]->(%s);',
+					$arg,
+					$varname,
+				);
+			}
+			$varname = '$tmp';
+		}
+		
+		if ($constraint->can_be_inlined)
+		{
+			push @code, sprintf(
+				'(%s) or Type::Tiny::_failed_check(%d, %s, %s, varname => %s);',
+				$constraint->inline_check($varname),
+				$constraint->{uniq},
+				B::perlstring($constraint),
+				$varname,
+				$is_slurpy ? 'q{$SLURPY}' : sprintf('q{$_{%s}}', B::perlstring($name)),
+			);
+		}
+		else
+		{
+			$env{'@check'}[$arg] = $constraint->compiled_check;
+			push @code, sprintf(
+				'%s or Type::Tiny::_failed_check(%d, %s, %s, varname => %s);',
+				sprintf(sprintf '$check[%d]->(%s)', $arg, $varname),
+				$constraint->{uniq},
+				B::perlstring($constraint),
+				$varname,
+				$is_slurpy ? 'q{$SLURPY}' : sprintf('q{$_{%s}}', B::perlstring($name)),
+			);
+		}
+		
+		push @code, sprintf('$R{%s} = %s;', B::perlstring($name), $varname);
+		
+		push @code, '}' if $need_to_close_if;
+	}
+	
+	if (!$had_slurpy) {
+		push @code, 'keys(%in) and "Error::TypeTiny"->throw(message => sprintf "Unrecognized parameter%s: %s", keys(%in)>1?"s":"", Type::Utils::english_list(sort keys %in));'
+	}
+	
+	push @code, '\\%R;';
+	
+	my $source  = "sub { no warnings; ".join("\n", @code)." };";
+	return $source if $options{want_source};
+	
+	my $closure = eval_closure(
+		source      => $source,
+		description => sprintf("parameter validation for '%s'", [caller(1+($options{caller_level}||0))]->[3] || '__ANON__'),
+		environment => \%env,
+	);
+	
+	return {
+		min_args   => undef,  # always going to be 1 or 0
+		max_args   => undef,  # should be possible to figure out if no slurpy param
+		closure    => $closure,
+	} if $options{want_details};
+	
+	return $closure;
+}
+
 my %compiled;
 sub validate
 {
 	my $arr = shift;
-	my $sub = $compiled{ join ":", map($_->{uniq}||"\@$_->{slurpy}", @_) } ||= compile({ caller_level => 1 }, @_);
+	my $sub = (
+		$compiled{ join ":", map($_->{uniq}||"\@$_->{slurpy}", @_) }
+			||= compile({ caller_level => 1 }, @_)
+	);
+	@_ = @$arr;
+	goto $sub;
+}
+
+my %compiled_named;
+sub validate_named
+{
+	my $arr = shift;
+	my $sub = (
+		$compiled_named{ join ":", map(ref($_)?($_->{uniq}||"\@$_->{slurpy}"):B::perlstring($_), @_) }
+			||= compile_named({ caller_level => 1 }, @_)
+	);
 	@_ = @$arr;
 	goto $sub;
 }
diff --git a/t/20-unit/Type-Params/compile-named.t b/t/20-unit/Type-Params/compile-named.t
new file mode 100644
index 0000000..c9fce71
--- /dev/null
+++ b/t/20-unit/Type-Params/compile-named.t
@@ -0,0 +1,311 @@
+=pod
+
+=encoding utf-8
+
+=head1 PURPOSE
+
+Test L<Type::Params>' brand spanking new C<compile_named> function.
+
+=head1 AUTHOR
+
+Toby Inkster E<lt>tobyink at cpan.orgE<gt>.
+
+=head1 COPYRIGHT AND LICENCE
+
+This software is copyright (c) 2013-2014 by Toby Inkster.
+
+This is free software; you can redistribute it and/or modify it under
+the same terms as the Perl 5 programming language system itself.
+
+
+=cut
+
+use strict;
+use warnings;
+
+use Test::More;
+use Test::Fatal;
+
+use Type::Params qw(compile_named validate_named);
+use Types::Standard -types, "slurpy";
+use Type::Utils;
+use Scalar::Util qw(refaddr);
+
+sub simple_test {
+	my ($name, @spec) = @_;
+	
+	local $Test::Builder::Level = $Test::Builder::Level + 1;
+	subtest $name => sub {
+		_simple_test( validate_named => sub { validate_named(\@_, @spec) } );
+		_simple_test( compile_named  => compile_named(@spec) );
+	};
+}
+
+sub slurpy_test {
+	my ($name, @spec) = @_;
+	
+	local $Test::Builder::Level = $Test::Builder::Level + 1;
+	subtest $name => sub {
+		_slurpy_test( validate_named => sub { validate_named(\@_, @spec) } );
+		_slurpy_test( compile_named  => compile_named(@spec) );
+	};
+}
+
+sub _simple_test {
+	my ($name, $check) = @_;
+	
+	local $Test::Builder::Level = $Test::Builder::Level + 1;
+	subtest $name, sub
+	{
+		is_deeply(
+			$check->( foo => 3, bar => 42 ),
+			{ foo => 3, bar => 42 },
+			'accept a hash',
+		);
+		
+		is_deeply(
+			$check->( foo => 3, bar => 42, baz => [1..3] ),
+			{ foo => 3, bar => 42, baz => [1..3] },
+			'accept a hash, with optional parameter',
+		);
+		
+		is_deeply(
+			$check->( foo => 3.1, bar => 42 ),
+			{ foo => 3, bar => 42 },
+			'accept a hash, and coerce',
+		);
+		
+		is_deeply(
+			$check->( foo => 3.1, bar => 42, baz => [1..3, 4.2] ),
+			{ foo => 3, bar => 42, baz => [1..4] },
+			'accept a hash, with optional parameter, and coerce',
+		);
+		
+		is_deeply(
+			$check->({ foo => 3, bar => 42 }),
+			{ foo => 3, bar => 42 },
+			'accept a hashref',
+		);
+		
+		is_deeply(
+			$check->({ foo => 3, bar => 42, baz => [1..3] }),
+			{ foo => 3, bar => 42, baz => [1..3] },
+			'accept a hashref, with optional parameter',
+		);
+		
+		is_deeply(
+			$check->({ foo => 3.1, bar => 42 }),
+			{ foo => 3, bar => 42 },
+			'accept a hashref, and coerce',
+		);
+		
+		is_deeply(
+			$check->({ foo => 3.1, bar => 42, baz => [1..3, 4.2] }),
+			{ foo => 3, bar => 42, baz => [1..4] },
+			'accept a hashref, with optional parameter, and coerce',
+		);
+		
+		like(
+			exception { $check->({ foo => [], bar => 42 }) },
+			qr/^Reference \[\] did not pass type constraint/,
+			'bad "foo" parameter',
+		);
+		
+		like(
+			exception { $check->({ foo => 3, bar => [] }) },
+			qr/^Reference \[\] did not pass type constraint/,
+			'bad "bar" parameter',
+		);
+		
+		like(
+			exception { $check->({ foo => {}, bar => [] }) },
+			qr/^Reference \{\} did not pass type constraint/,
+			'two bad parameters; "foo" throws before "bar" gets a chance',
+		);
+		
+		like(
+			exception { $check->({ foo => 3, bar => 42, baz => {} }) },
+			qr/^Reference \{\} did not pass type constraint/,
+			'bad optional "baz" parameter',
+		);
+		
+		like(
+			exception { $check->({ foo => 3, bar => 42, xxx => 1 }) },
+			qr/^Unrecognized parameter: xxx/,
+			'additional parameter',
+		);
+		
+		like(
+			exception { $check->({ foo => 3, bar => 42, xxx => 1, yyy => 2, zzz => 3 }) },
+			qr/^Unrecognized parameters: xxx, yyy, and zzz/,
+			'additional parameters',
+		);
+		
+		like(
+			exception { $check->({ }) },
+			qr/^Missing required parameter: foo/,
+			'missing parameter',
+		);
+	};
+}
+
+sub _slurpy_test {
+	my ($name, $check) = @_;
+	
+	local $Test::Builder::Level = $Test::Builder::Level + 1;
+	subtest $name, sub
+	{
+		is_deeply(
+			$check->( foo => 3, bar => 42 ),
+			{ XXX => {}, foo => 3, bar => 42 },
+			'accept a hash',
+		);
+		
+		is_deeply(
+			$check->( foo => 3, bar => 42, baz => [1..3] ),
+			{ XXX => {}, foo => 3, bar => 42, baz => [1..3] },
+			'accept a hash, with optional parameter',
+		);
+		
+		is_deeply(
+			$check->( foo => 3.1, bar => 42 ),
+			{ XXX => {}, foo => 3, bar => 42 },
+			'accept a hash, and coerce',
+		);
+		
+		is_deeply(
+			$check->( foo => 3.1, bar => 42, baz => [1..3, 4.2] ),
+			{ XXX => {}, foo => 3, bar => 42, baz => [1..4] },
+			'accept a hash, with optional parameter, and coerce',
+		);
+		
+		is_deeply(
+			$check->({ foo => 3, bar => 42 }),
+			{ XXX => {}, foo => 3, bar => 42 },
+			'accept a hashref',
+		);
+		
+		is_deeply(
+			$check->({ foo => 3, bar => 42, baz => [1..3] }),
+			{ XXX => {}, foo => 3, bar => 42, baz => [1..3] },
+			'accept a hashref, with optional parameter',
+		);
+		
+		is_deeply(
+			$check->({ foo => 3.1, bar => 42 }),
+			{ XXX => {}, foo => 3, bar => 42 },
+			'accept a hashref, and coerce',
+		);
+		
+		is_deeply(
+			$check->({ foo => 3.1, bar => 42, baz => [1..3, 4.2] }),
+			{ XXX => {}, foo => 3, bar => 42, baz => [1..4] },
+			'accept a hashref, with optional parameter, and coerce',
+		);
+		
+		like(
+			exception { $check->({ foo => [], bar => 42 }) },
+			qr/^Reference \[\] did not pass type constraint/,
+			'bad "foo" parameter',
+		);
+		
+		like(
+			exception { $check->({ foo => 3, bar => [] }) },
+			qr/^Reference \[\] did not pass type constraint/,
+			'bad "bar" parameter',
+		);
+		
+		like(
+			exception { $check->({ foo => {}, bar => [] }) },
+			qr/^Reference \{\} did not pass type constraint/,
+			'two bad parameters; "foo" throws before "bar" gets a chance',
+		);
+		
+		like(
+			exception { $check->({ foo => 3, bar => 42, baz => {} }) },
+			qr/^Reference \{\} did not pass type constraint/,
+			'bad optional "baz" parameter',
+		);
+		
+		is_deeply(
+			$check->({ foo => 3, bar => 42, xxx => 1 }),
+			{ XXX => { xxx => 1 }, foo => 3, bar => 42 },
+			'additional parameter',
+		);
+		
+		is_deeply(
+			$check->({ foo => 3, bar => 42, xxx => 1, yyy => 2, zzz => 3 }),
+			{ XXX => { xxx => 1, yyy => 2, zzz => 3 }, foo => 3, bar => 42 },
+			'additional parameters',
+		);
+
+		is_deeply(
+			$check->({ foo => 3, bar => 42, xxx => 1.1, yyy => 2.2, zzz => 3 }),
+			{ XXX => { xxx => 1, yyy => 2, zzz => 3 }, foo => 3, bar => 42 },
+			'coercion of additional parameters',
+		);
+
+		like(
+			exception { $check->({ }) },
+			qr/^Missing required parameter: foo/,
+			'missing parameter',
+		);
+	};
+}
+
+
+my $Rounded;
+
+$Rounded = Int->plus_coercions(Num, q{ int($_) });
+simple_test(
+	"simple test with everything inlineable",
+	foo => $Rounded,
+	bar => Int,
+	baz => Optional[ArrayRef->of($Rounded)],
+);
+
+$Rounded = Int->plus_coercions(Num, sub { int($_) });
+simple_test(
+	"simple test with inlineable types, but non-inlineable coercion", 
+	foo => $Rounded,
+	bar => Int,
+	baz => Optional[ArrayRef->of($Rounded)],
+);
+
+$Rounded = Int->where(sub { !!1 })->plus_coercions(Num, sub { int($_) });
+simple_test(
+	"simple test with everything non-inlineable", 
+	foo => $Rounded,
+	bar => Int->where(sub { !!1 }),
+	baz => Optional[ArrayRef->of($Rounded)],
+);
+
+$Rounded = Int->plus_coercions(Num, q{ int($_) });
+slurpy_test(
+	"slurpy test with everything inlineable",
+	foo => $Rounded,
+	bar => Int,
+	baz => Optional[ArrayRef->of($Rounded)],
+	XXX => slurpy HashRef[$Rounded],
+);
+
+$Rounded = Int->plus_coercions(Num, sub { int($_) });
+slurpy_test(
+	"slurpy test with inlineable types, but non-inlineable coercion", 
+	foo => $Rounded,
+	bar => Int,
+	baz => Optional[ArrayRef->of($Rounded)],
+	XXX => slurpy HashRef[$Rounded],
+);
+
+$Rounded = Int->where(sub { !!1 })->plus_coercions(Num, sub { int($_) });
+slurpy_test(
+	"slurpy test with everything non-inlineable", 
+	foo => $Rounded,
+	bar => Int->where(sub { !!1 }),
+	baz => Optional[ArrayRef->of($Rounded)],
+	XXX => slurpy HashRef[$Rounded],
+);
+
+
+done_testing;

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



More information about the Pkg-perl-cvs-commits mailing list