Commit | Line | Data |
06d16be0 |
1 | #!/usr/bin/env perl |
2 | use strict; |
3 | use warnings; |
4 | use Test::More; |
5 | use Test::Exception; |
6 | |
7 | { |
8 | use Moose::Util::TypeConstraints; |
9 | use List::Util qw(sum); |
10 | |
11 | subtype 'A1', as 'ArrayRef[Int]'; |
12 | subtype 'A2', as 'ArrayRef', where { @$_ < 2 }; |
13 | subtype 'A3', as 'ArrayRef[Int]', where { sum @$_ < 5 }; |
14 | |
15 | no Moose::Util::TypeConstraints; |
16 | } |
17 | |
18 | { |
19 | package Foo; |
20 | use Moose; |
21 | |
22 | has array => ( |
23 | traits => ['Array'], |
24 | is => 'rw', |
25 | isa => 'ArrayRef', |
26 | handles => { |
27 | push_array => 'push', |
28 | }, |
29 | ); |
30 | has array_int => ( |
31 | traits => ['Array'], |
32 | is => 'rw', |
33 | isa => 'ArrayRef[Int]', |
34 | handles => { |
35 | push_array_int => 'push', |
36 | }, |
37 | ); |
38 | has a1 => ( |
39 | traits => ['Array'], |
40 | is => 'rw', |
41 | isa => 'A1', |
42 | handles => { |
43 | push_a1 => 'push', |
44 | }, |
45 | ); |
46 | has a2 => ( |
47 | traits => ['Array'], |
48 | is => 'rw', |
49 | isa => 'A2', |
50 | handles => { |
51 | push_a2 => 'push', |
52 | }, |
53 | ); |
54 | has a3 => ( |
55 | traits => ['Array'], |
56 | is => 'rw', |
57 | isa => 'A3', |
58 | handles => { |
59 | push_a3 => 'push', |
60 | }, |
61 | ); |
62 | } |
63 | |
64 | my $foo = Foo->new; |
65 | |
66 | { |
67 | my $array = []; |
68 | dies_ok { $foo->push_array('foo') } "can't push onto undef"; |
69 | |
70 | $foo->array($array); |
71 | is($foo->array, $array, "same ref"); |
72 | is_deeply($foo->array, [], "correct contents"); |
73 | |
74 | $foo->push_array('foo'); |
75 | is($foo->array, $array, "same ref"); |
76 | is_deeply($foo->array, ['foo'], "correct contents"); |
77 | } |
78 | |
79 | { |
80 | my $array = []; |
81 | dies_ok { $foo->push_array_int(1) } "can't push onto undef"; |
82 | |
83 | $foo->array_int($array); |
84 | is($foo->array_int, $array, "same ref"); |
85 | is_deeply($foo->array_int, [], "correct contents"); |
86 | |
87 | dies_ok { $foo->push_array_int('foo') } "can't push wrong type"; |
88 | is($foo->array_int, $array, "same ref"); |
89 | is_deeply($foo->array_int, [], "correct contents"); |
90 | @$array = (); |
91 | |
92 | $foo->push_array_int(1); |
93 | is($foo->array_int, $array, "same ref"); |
94 | is_deeply($foo->array_int, [1], "correct contents"); |
95 | } |
96 | |
97 | { |
98 | my $array = []; |
99 | dies_ok { $foo->push_a1('foo') } "can't push onto undef"; |
100 | |
101 | $foo->a1($array); |
102 | is($foo->a1, $array, "same ref"); |
103 | is_deeply($foo->a1, [], "correct contents"); |
104 | |
105 | { local $TODO = "type parameters aren't checked on subtypes"; |
106 | dies_ok { $foo->push_a1('foo') } "can't push wrong type"; |
107 | } |
108 | is($foo->a1, $array, "same ref"); |
109 | { local $TODO = "type parameters aren't checked on subtypes"; |
110 | is_deeply($foo->a1, [], "correct contents"); |
111 | } |
112 | @$array = (); |
113 | |
114 | $foo->push_a1(1); |
115 | is($foo->a1, $array, "same ref"); |
116 | is_deeply($foo->a1, [1], "correct contents"); |
117 | } |
118 | |
119 | { |
120 | my $array = []; |
121 | dies_ok { $foo->push_a2('foo') } "can't push onto undef"; |
122 | |
123 | $foo->a2($array); |
124 | is($foo->a2, $array, "same ref"); |
125 | is_deeply($foo->a2, [], "correct contents"); |
126 | |
127 | $foo->push_a2('foo'); |
128 | is($foo->a2, $array, "same ref"); |
129 | is_deeply($foo->a2, ['foo'], "correct contents"); |
130 | |
131 | { local $TODO = "overall tcs aren't checked"; |
132 | dies_ok { $foo->push_a2('bar') } "can't push more than one element"; |
133 | } |
134 | is($foo->a2, $array, "same ref"); |
135 | { local $TODO = "overall tcs aren't checked"; |
136 | is_deeply($foo->a2, ['foo'], "correct contents"); |
137 | } |
138 | } |
139 | |
140 | { |
141 | my $array = []; |
142 | dies_ok { $foo->push_a3(1) } "can't push onto undef"; |
143 | |
144 | $foo->a3($array); |
145 | is($foo->a3, $array, "same ref"); |
146 | is_deeply($foo->a3, [], "correct contents"); |
147 | |
148 | { local $TODO = "tc parameters aren't checked on subtypes"; |
149 | dies_ok { $foo->push_a3('foo') } "can't push non-int"; |
150 | } |
151 | { local $TODO = "overall tcs aren't checked"; |
152 | dies_ok { $foo->push_a3(100) } "can't violate overall type constraint"; |
153 | } |
154 | is($foo->a3, $array, "same ref"); |
155 | { local $TODO = "tc checks are broken"; |
156 | is_deeply($foo->a3, [], "correct contents"); |
157 | } |
158 | @$array = (); |
159 | |
160 | $foo->push_a3(1); |
161 | is($foo->a3, $array, "same ref"); |
162 | is_deeply($foo->a3, [1], "correct contents"); |
163 | |
164 | { local $TODO = "overall tcs aren't checked"; |
165 | dies_ok { $foo->push_a3(100) } "can't violate overall type constraint"; |
166 | } |
167 | is($foo->a3, $array, "same ref"); |
168 | { local $TODO = "overall tcs aren't checked"; |
169 | is_deeply($foo->a3, [1], "correct contents"); |
170 | } |
171 | @$array = (1); |
172 | |
173 | $foo->push_a3(3); |
174 | is($foo->a3, $array, "same ref"); |
175 | is_deeply($foo->a3, [1, 3], "correct contents"); |
176 | } |
177 | |
178 | done_testing; |