[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