Merge f08a33e into 1842af3

lib/Type/Params.pm

@@ -20,7 +20,7 @@ use Error::TypeTiny;
 use Error::TypeTiny::Assertion;
 use Error::TypeTiny::WrongNumberOfParameters;
 use Types::Standard -types;
-use Types::TypeTiny qw(CodeLike TypeTiny ArrayLike to_TypeTiny);
+use Types::TypeTiny qw(CodeLike TypeTiny ArrayLike StringLike to_TypeTiny);
 
 require Exporter::Tiny;
 our @ISA = 'Exporter::Tiny';
@@ -654,12 +654,20 @@ sub validate_named
 sub multisig
 {
 	my %options = (ref($_[0]) eq "HASH" && !$_[0]{slurpy}) ? %{+shift} : ();
+    $options{message}     ||= "Parameter validation failed";
+    $options{description} ||= sprintf("parameter validation for '%s'", [caller(1+($options{caller_level}||0))]->[3] || '__ANON__');
+    for my $key ( qw[ message description ] )
+    {
+        StringLike->check($options{$key})
+            || Error::TypeTiny::croak("Option '$key' expected to be string or stringifiable object");
+    }
+
 	my @multi = map {
 		CodeLike->check($_)  ? { closure => $_ } :
 		ArrayLike->check($_) ? compile({ want_details => 1 }, @$_) :
 		$_;
 	} @_;
-	
+
 	my @code = 'sub { my $r; ';
 
 	for my $i (0 .. $#multi)
@@ -679,12 +687,12 @@ sub multisig
 		push @code, '}' if @cond;
 	}
 
-	push @code, '"Error::TypeTiny"->throw(message => "Parameter validation failed");';
+	push @code, sprintf('"Error::TypeTiny"->throw(message => "%s");', quotemeta("$options{message}"));
 	push @code, '}';
 
 	eval_closure(
 		source      => \@code,
-		description => sprintf("parameter validation for '%s'", [caller(1+($options{caller_level}||0))]->[3] || '__ANON__'),
+		description => $options{description},
 		environment => { '@multi' => \@multi },
 	);
 }
@@ -1143,6 +1151,21 @@ a full example:
    get_from(0, \@array);      # returns $array[0]
    get_from('foo', \%hash);   # returns $hash{foo}
    get_from('foo', $obj);     # returns $obj->foo
+   
+The default error message is just C<"Parameter validation failed">.
+You can pass an option hashref as the first argument with a 
+hopefully more informative message string:
+
+    sub foo {
+        state $OptionsDict = Dict[...];
+        state $check = multisig(
+            { message => 'USAGE: $object->foo($string [, \%options|%options])', },
+            [ Object, StringLike, $OptionsDict ],
+            [ Object, StringLike, slurpy $OptionsDict ],
+        );
+        my($self, $string, $opt) = $check->(@_);
+        ...
+    }
 
 =head1 PARAMETER OBJECTS
 

t/20-unit/Type-Params/multisig-custom-message.t

@@ -0,0 +1,108 @@
+=pod
+
+=encoding utf-8
+
+=head1 PURPOSE
+
+Make sure that custom C<multisig()> messages work.
+
+=head1 AUTHOR
+
+Benct Philip Jonsson E<lt>bpjonsson@gmail.comE<gt>.
+
+=head1 COPYRIGHT AND LICENCE
+
+This software is copyright (c) 2018 by Benct Philip Jonsson.
+
+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( multisig );
+use Types::Standard qw( Optional Str Int Bool Dict slurpy );
+
+
+sub _maybe_slurpy {
+    my @sig = @_;
+    $sig[-1] = slurpy $sig[-1];
+    return ( [@_], \@sig );
+}
+
+my $foo_args;
+sub foo {
+    $foo_args ||= multisig(
+        {   description => "parameter validation for foo()",
+            message => 'USAGE: foo($string [, \%options|%options])',
+        },
+        _maybe_slurpy( Str, Dict[ bool => Optional[Bool], num => Optional[Int] ] ),
+    );
+    return $foo_args->(@_);
+}
+
+my $bar_args;
+sub bar {
+    $bar_args ||= multisig(
+        {   description => "parameter validation for bar()",
+            message => 'USAGE: bar()',
+        },
+        [],
+    );
+    return $bar_args->(@_);
+}
+
+my @tests = (
+    [ 'bar(1)' => sub { bar( 1 ) }, 'USAGE: bar()', undef ],
+    [ 'bar()'  => sub { bar() },    "",             0 ],
+    [   'foo($string, num => "x")' => sub { foo( "baz", num => "x" ) },
+        'USAGE: foo($string [, \\%options|%options])', 0
+    ],
+    [   'foo([], num => 42)' => sub { foo( [], num => 42 ) },
+        'USAGE: foo($string [, \\%options|%options])', 0
+    ],
+    [   'foo($string, quux => 0)' => sub { foo( "baz", quux => 0 ) },
+        'USAGE: foo($string [, \\%options|%options])', 0
+    ],
+    [   'foo($string, [])' => sub { foo( "baz", [] ) },
+        'USAGE: foo($string [, \\%options|%options])', 0
+    ],
+    [   'foo($string, bool => 1)',
+        sub {
+            is_deeply [ foo( "baz", bool => 1 ) ], [ "baz", { bool => 1 } ],
+              'slurpy options';
+        },
+        "",
+        1
+    ],
+    [   'foo($string, { bool => 1 })',
+        sub {
+            is_deeply [ foo( "baz", { bool => 1 } ) ], [ "baz", { bool => 1 } ],
+              'hashref options';
+        },
+        "",
+        0
+    ],
+    [   'foo($string)',
+        sub {
+            is_deeply [ foo( "baz" ) ], [ "baz", {} ], 'no options';
+        },
+        "",
+        1
+    ],
+);
+
+for my $test ( @tests ) {
+    no warnings 'uninitialized';
+    my($name, $code, $expected, $sig) = @$test;
+    like( exception { $code->() }, qr/\A\Q$expected/, $name);
+    is ${^TYPE_PARAMS_MULTISIG}, $sig, "$name \${^TYPE_PARAMS_MULTISIG}";
+}
+
+done_testing;