support custom non-moose type constraints (#85851)

diff --git a/MANIFEST b/MANIFEST
index 68ec43f..ffa02de 100644 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
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 (file)
--- 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