Commit | Line | Data |
182134e8 |
1 | #!/usr/bin/perl |
2 | |
3 | use strict; |
4 | use warnings; |
5 | |
a28e50e4 |
6 | use Test::More; |
b10dde3a |
7 | use Test::Fatal; |
182134e8 |
8 | |
28fdde7f |
9 | use Moose::Util::TypeConstraints; |
182134e8 |
10 | |
11 | { |
12 | package HTTPHeader; |
182134e8 |
13 | use Moose; |
d03bd989 |
14 | |
182134e8 |
15 | has 'array' => (is => 'ro'); |
d03bd989 |
16 | has 'hash' => (is => 'ro'); |
182134e8 |
17 | } |
18 | |
d03bd989 |
19 | subtype Header => |
20 | => as Object |
182134e8 |
21 | => where { $_->isa('HTTPHeader') }; |
d03bd989 |
22 | |
23 | coerce Header |
24 | => from ArrayRef |
d6e2d9a1 |
25 | => via { HTTPHeader->new(array => $_[0]) } |
d03bd989 |
26 | => from HashRef |
d6e2d9a1 |
27 | => via { HTTPHeader->new(hash => $_[0]) }; |
81dc201f |
28 | |
d03bd989 |
29 | |
30 | Moose::Util::TypeConstraints->export_type_constraints_as_functions(); |
31 | |
182134e8 |
32 | my $header = HTTPHeader->new(); |
33 | isa_ok($header, 'HTTPHeader'); |
34 | |
35 | ok(Header($header), '... this passed the type test'); |
36 | ok(!Header([]), '... this did not pass the type test'); |
37 | ok(!Header({}), '... this did not pass the type test'); |
38 | |
470b518a |
39 | my $anon_type = subtype Object => where { $_->isa('HTTPHeader') }; |
182134e8 |
40 | |
b10dde3a |
41 | is( exception { |
470b518a |
42 | coerce $anon_type |
d03bd989 |
43 | => from ArrayRef |
470b518a |
44 | => via { HTTPHeader->new(array => $_[0]) } |
d03bd989 |
45 | => from HashRef |
470b518a |
46 | => via { HTTPHeader->new(hash => $_[0]) }; |
b10dde3a |
47 | }, undef, 'coercion of anonymous subtype succeeds' ); |
e90c03d0 |
48 | |
470b518a |
49 | foreach my $coercion ( |
50 | find_type_constraint('Header')->coercion, |
51 | $anon_type->coercion |
52 | ) { |
e90c03d0 |
53 | |
470b518a |
54 | isa_ok($coercion, 'Moose::Meta::TypeCoercion'); |
d03bd989 |
55 | |
470b518a |
56 | { |
57 | my $coerced = $coercion->coerce([ 1, 2, 3 ]); |
58 | isa_ok($coerced, 'HTTPHeader'); |
d03bd989 |
59 | |
470b518a |
60 | is_deeply( |
61 | $coerced->array(), |
62 | [ 1, 2, 3 ], |
63 | '... got the right array'); |
d03bd989 |
64 | is($coerced->hash(), undef, '... nothing assigned to the hash'); |
470b518a |
65 | } |
d03bd989 |
66 | |
470b518a |
67 | { |
68 | my $coerced = $coercion->coerce({ one => 1, two => 2, three => 3 }); |
69 | isa_ok($coerced, 'HTTPHeader'); |
d03bd989 |
70 | |
470b518a |
71 | is_deeply( |
72 | $coerced->hash(), |
73 | { one => 1, two => 2, three => 3 }, |
74 | '... got the right hash'); |
d03bd989 |
75 | is($coerced->array(), undef, '... nothing assigned to the array'); |
470b518a |
76 | } |
d03bd989 |
77 | |
470b518a |
78 | { |
79 | my $scalar_ref = \(my $var); |
80 | my $coerced = $coercion->coerce($scalar_ref); |
81 | is($coerced, $scalar_ref, '... got back what we put in'); |
82 | } |
d03bd989 |
83 | |
470b518a |
84 | { |
85 | my $coerced = $coercion->coerce("Foo"); |
86 | is($coerced, "Foo", '... got back what we put in'); |
87 | } |
e90c03d0 |
88 | } |
88071df7 |
89 | |
a232d913 |
90 | subtype 'StrWithTrailingX' |
91 | => as 'Str' |
92 | => where { /X$/ }; |
88071df7 |
93 | |
a232d913 |
94 | coerce 'StrWithTrailingX' |
95 | => from 'Str' |
96 | => via { $_ . 'X' }; |
88071df7 |
97 | |
a232d913 |
98 | my $tc = find_type_constraint('StrWithTrailingX'); |
99 | is($tc->coerce("foo"), "fooX", "coerce when needed"); |
100 | is($tc->coerce("fooX"), "fooX", "do not coerce when unneeded"); |
a28e50e4 |
101 | |
102 | done_testing; |