1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
|
#!/usr/bin/perl
use v5.22;
use warnings;
use Test2::V0;
use lib "t";
use testcase "t::test", qw( test_constraint );
use Data::Checks qw( Defined Object Str Isa Can ArrayRef HashRef Callable );
# Defined
{
my $checker = t::test::make_checkdata( Defined, "Value" );
ok( t::test::check_value( $checker, "ok" ), 'Defined accepts value' );
ok( !t::test::check_value( $checker, undef ), 'Defined rejects undef' );
is( dies { t::test::assert_value( $checker, "ok" ) }, undef,
'Defined assert_value OK' );
like( dies { t::test::assert_value( $checker, undef ) },
qr/^Value requires a value satisfying Defined at /,
'Defined assert_value bad' );
my $asserter = t::test::make_asserter_sub( $checker );
is( dies { $asserter->( "ok" ) }, undef,
'Defined asserter OK' );
like( dies { $asserter->( undef ) },
qr/^Value requires a value satisfying Defined at /,
'Defined asserter bad' );
t::test::free_checkdata( $checker );
}
# Constraints have a ->check method directly
{
ok( Defined->check( 123 ), 'Defined->check accepts defined value' );
ok( !Defined->check( undef ), 'Defined->check rejects undef' );
}
# Object
test_constraint Object => Object,
[
'object' => BaseClass->new,
];
# unit constraint functions don't take arguments
{
# Perls before 5.34 did not include argument count in the message
my $argc_re = $^V ge v5.34 ? qr/ \(got 1; expected 0\)/ : "";
like( dies { Defined(123) },
qr/^Too many arguments for subroutine 'Data::Checks::Defined'$argc_re at /,
'unit constraint functions complain if given arguments' );
}
# Isa
test_constraint Isa => Isa("BaseClass"),
[
'object' => BaseClass->new,
'subclass' => DerivedClass->new,
],
[
'class name' => "BaseClass",
'other instance' => DifferentClass->new,
];
# Can
test_constraint Can => Can("basem"),
[
'object' => BaseClass->new,
'subclass' => DerivedClass->new,
'package name' => "BaseClass",
],
[
'other instance' => DifferentClass->new,
];
# Can (multi)
test_constraint Can => Can("basem", "new", "can"),
[
'object' => BaseClass->new,
'subclass' => DerivedClass->new,
'package name' => "BaseClass",
];
# ArrayRef
test_constraint ArrayRef => ArrayRef,
[
'plain arrayref' => [],
'object with @{}' => ClassWithArrayRefify->new,
];
# HashRef
test_constraint HashRef => HashRef,
[
'plain hashref' => {},
'object with %{}' => ClassWithHashRefify->new,
];
# Callable
test_constraint Callable => Callable,
[
'plain coderef' => sub {},
'ref to CORE::join' => \&CORE::join,
'object with &{}' => ClassWithCodeRefify->new,
];
# Stringification
is( Data::Checks::Debug::stringify_constraint( Defined ), "Defined",
'debug stringify Defined' );
is( Data::Checks::Debug::stringify_constraint( Object ), "Object",
'debug stringify Object' );
is( Data::Checks::Debug::stringify_constraint( Isa("Base::Class") ), "Isa(\"Base::Class\")",
'debug stringify Isa("Base::Class")' );
is( Data::Checks::Debug::stringify_constraint( Can("red", "blue") ), "Can(\"red\", \"blue\")",
'debug stringify Can("red", "blue")' );
is( Data::Checks::Debug::stringify_constraint( ArrayRef ), "ArrayRef",
'debug stringify ArrayRef' );
is( Data::Checks::Debug::stringify_constraint( HashRef ), "HashRef",
'debug stringify HashRef' );
is( Data::Checks::Debug::stringify_constraint( Callable ), "Callable",
'debug stringify Callable' );
done_testing;
|
