From: Lukas Mai Date: Sun, 9 Jun 2013 01:13:26 +0000 (+0200) Subject: support custom non-moose type constraints (#85851) X-Git-Tag: v1.0103~2 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?p=p5sagit%2FFunction-Parameters.git;a=commitdiff_plain;h=52c18b0fcd23a30bd0602102a97f90cb5dd81b79 support custom non-moose type constraints (#85851) --- diff --git a/MANIFEST b/MANIFEST index 68ec43f..ffa02de 100644 --- a/MANIFEST +++ b/MANIFEST @@ -88,8 +88,6 @@ t/invocant.t t/lexical.t t/lineno-torture.t t/lineno.t -t/moose_types.t -t/moosex_types.t t/name.t t/name_1.fail t/name_2.fail @@ -108,4 +106,8 @@ t/strict_2.fail t/strict_3.fail t/strict_4.fail t/strict_5.fail +t/types_custom.t +t/types_moose.t +t/types_moose_2.t +t/types_moosex.t t/unicode.t diff --git a/Makefile.PL b/Makefile.PL index 1f0868b..3b0cdc6 100644 --- a/Makefile.PL +++ b/Makefile.PL @@ -16,6 +16,7 @@ WriteMakefile( LICENSE => 'perl', PL_FILES => {}, BUILD_REQUIRES => { + 'constant' => 0, 'strict' => 0, 'Dir::Self' => 0, 'Test::More' => 0, diff --git a/Parameters.xs b/Parameters.xs index fa8e4ee..8f77a63 100644 --- a/Parameters.xs +++ b/Parameters.xs @@ -220,6 +220,15 @@ static int my_sv_eq_pvn(pTHX_ SV *sv, const char *p, STRLEN n) { #include "padop_on_crack.c.inc" +static void my_require(pTHX_ const char *file) { + SV *err; + require_pv(file); + err = ERRSV; + if (SvTRUE(err)) { + croak_sv(err); + } +} + enum { MY_ATTR_LVALUE = 0x01, MY_ATTR_METHOD = 0x02, @@ -502,6 +511,8 @@ static SV *reify_type(pTHX_ Sentinel sen, const SV *declarator, SV *name) { int n; dSP; + my_require(aTHX_ "Moose/Util/TypeConstraints.pm"); + ENTER; SAVETMPS; @@ -712,15 +723,6 @@ static size_t count_named_params(const ParamSpec *ps) { return ps->named_required.used + ps->named_optional.used; } -static void my_require(pTHX_ const char *file) { - SV *err; - require_pv(file); - err = ERRSV; - if (SvTRUE(err)) { - croak_sv(err); - } -} - static SV *my_eval(pTHX_ Sentinel sen, I32 floor, OP *op) { SV *sv; CV *cv; @@ -798,7 +800,9 @@ static PADOFFSET parse_param( sentinel_disarm(expr_sentinel); } *ptype = my_eval(aTHX_ sen, floor, expr); - *ptype = reify_type(aTHX_ sen, declarator, *ptype); + if (!SvROK(*ptype)) { + *ptype = reify_type(aTHX_ sen, declarator, *ptype); + } if (!sv_isobject(*ptype)) { croak("In %"SVf": (%"SVf") doesn't look like a type object", SVfARG(declarator), SVfARG(*ptype)); } @@ -806,7 +810,6 @@ static PADOFFSET parse_param( c = lex_peek_unichar(0); } else if (MY_UNI_IDFIRST(c)) { *ptype = parse_type(aTHX_ sen, declarator); - my_require(aTHX_ "Moose/Util/TypeConstraints.pm"); *ptype = reify_type(aTHX_ sen, declarator, *ptype); c = lex_peek_unichar(0); diff --git a/t/types_custom.t b/t/types_custom.t new file mode 100644 index 0000000..df5c028 --- /dev/null +++ b/t/types_custom.t @@ -0,0 +1,49 @@ +#!perl +use warnings FATAL => 'all'; +use strict; + +use Test::More tests => 4; +use Test::Fatal; + +use Function::Parameters qw(:strict); + +{ + package MyTC; + + method new( + $class: + $name, + $check, + $get_message = fun ($value) { + "Validation failed for constraint '$name' with value '$value'" + }, + ) { + bless { + name => $name, + check => $check, + get_message => $get_message, + }, $class + } + + method check($value) { + $self->{check}($value) + } + + method get_message($value) { + $self->{get_message}($value) + } +} + +use constant { + TEvenNum => MyTC->new('even number' => fun ($n) { $n =~ /^[0-9]+\z/ && $n % 2 == 0 }), + TShortStr => MyTC->new('short string' => fun ($s) { length($s) < 10 }), +}; + +fun foo((TEvenNum) $x, (TShortStr) $y) { + "$x/$y" +} + +is foo(42, "hello"), "42/hello"; +like exception { foo 41, "hello" }, qr{\bValidation failed for constraint 'even number' with value '41'}; +like exception { foo 42, "1234567890~" }, qr{\bValidation failed for constraint 'short string' with value '1234567890~'}; +like exception { foo 41, "1234567890~" }, qr{\bValidation failed for constraint 'even number' with value '41'}; diff --git a/t/moose_types.t b/t/types_moose.t similarity index 100% copy from t/moose_types.t copy to t/types_moose.t diff --git a/t/moose_types.t b/t/types_moose_2.t similarity index 88% rename from t/moose_types.t rename to t/types_moose_2.t index 1f5344d..2533cfe 100644 --- a/t/moose_types.t +++ b/t/types_moose_2.t @@ -3,7 +3,7 @@ use warnings FATAL => 'all'; use strict; use Test::More - eval { require Moose; 1 } + eval { require Moose::Util; 1 } ? (tests => 49) : (skip_all => "Moose required for testing types") ; @@ -11,7 +11,7 @@ use Test::Fatal; use Function::Parameters qw(:strict); -fun foo(Int $n, CodeRef $f, $x) { +fun foo(('Int') $n, ('CodeRef') $f, $x) { $x = $f->($x) for 1 .. $n; $x } @@ -19,7 +19,7 @@ fun foo(Int $n, CodeRef $f, $x) { is foo(0, fun {}, undef), undef; is foo(0, fun {}, "o hai"), "o hai"; is foo(3, fun ($x) { "($x)" }, 1.5), "(((1.5)))"; -is foo(3, fun (Str $x) { "($x)" }, 1.5), "(((1.5)))"; +is foo(3, fun (('Str') $x) { "($x)" }, 1.5), "(((1.5)))"; { my $info = Function::Parameters::info \&foo; @@ -41,7 +41,14 @@ is foo(3, fun (Str $x) { "($x)" }, 1.5), "(((1.5)))"; like exception { foo("ermagerd", fun {}, undef) }, qr/\bparameter 1.+\$n\b.+\bValidation failed\b.+\bInt\b.+ermagerd/; like exception { foo(0, {}, undef) }, qr/\bparameter 2.+\$f\b.+\bValidation failed\b.+\bCodeRef\b/; -fun bar(((Function::Parameters::info(\&foo)->positional_required)[0]->type) $whoa) { $whoa * 2 } +fun bar( + ( + do { + require Moose; + (Function::Parameters::info(\&foo)->positional_required)[0]->type + } + ) $whoa +) { $whoa * 2 } is bar(21), 42; { @@ -58,7 +65,7 @@ is bar(21), 42; } { - my $info = Function::Parameters::info(fun ( ArrayRef [ Int | CodeRef ]@nom) {}); + my $info = Function::Parameters::info(fun ( (q~ArrayRef [ Int | CodeRef ]~ )@nom) {}); is $info->invocant, undef; is $info->positional_required, 0; is $info->positional_optional, 0; diff --git a/t/moosex_types.t b/t/types_moosex.t similarity index 100% rename from t/moosex_types.t rename to t/types_moosex.t