Commit | Line | Data |
29dcbf33 |
1 | #!/usr/bin/env perl |
2 | |
3 | use strict; |
4 | use warnings; |
5 | |
6 | use Test::More; |
53a4d826 |
7 | use Test::Exception; |
29dcbf33 |
8 | |
9 | { |
10 | use Moose::Util::TypeConstraints; |
11 | use List::Util qw( sum ); |
12 | |
13 | subtype 'H1', as 'HashRef[Int]'; |
14 | subtype 'H2', as 'HashRef', where { scalar keys %{$_} < 2 }; |
15 | subtype 'H3', as 'HashRef[Int]', |
16 | where { ( sum( values %{$_} ) || 0 ) < 5 }; |
17 | |
18 | no Moose::Util::TypeConstraints; |
19 | } |
20 | |
21 | { |
22 | |
23 | package Foo; |
24 | use Moose; |
25 | |
26 | has hash_int => ( |
27 | traits => ['Hash'], |
28 | is => 'rw', |
29 | isa => 'HashRef[Int]', |
30 | handles => { |
31 | set_hash_int => 'set', |
32 | }, |
33 | ); |
34 | |
35 | has h1 => ( |
36 | traits => ['Hash'], |
37 | is => 'rw', |
38 | isa => 'H1', |
39 | handles => { |
40 | set_h1 => 'set', |
41 | }, |
42 | ); |
43 | |
44 | has h2 => ( |
45 | traits => ['Hash'], |
46 | is => 'rw', |
47 | isa => 'H2', |
48 | handles => { |
49 | set_h2 => 'set', |
50 | }, |
51 | ); |
52 | |
53 | has h3 => ( |
54 | traits => ['Hash'], |
55 | is => 'rw', |
56 | isa => 'H3', |
57 | handles => { |
58 | set_h3 => 'set', |
59 | }, |
60 | ); |
61 | } |
62 | |
63 | my $foo = Foo->new; |
64 | |
65 | { |
66 | $foo->hash_int( {} ); |
67 | is_deeply( $foo->hash_int, {}, "hash_int - correct contents" ); |
68 | |
53a4d826 |
69 | dies_ok { $foo->set_hash_int( x => 'foo' ) } |
29dcbf33 |
70 | "hash_int - can't set wrong type"; |
71 | is_deeply( $foo->hash_int, {}, "hash_int - correct contents" ); |
72 | |
73 | $foo->set_hash_int( x => 1 ); |
74 | is_deeply( $foo->hash_int, { x => 1 }, "hash_int - correct contents" ); |
75 | } |
76 | |
77 | { |
53a4d826 |
78 | dies_ok { $foo->set_h1('foo') } "h1 - can't set onto undef"; |
29dcbf33 |
79 | |
80 | $foo->h1( {} ); |
81 | is_deeply( $foo->h1, {}, "h1 - correct contents" ); |
82 | |
53a4d826 |
83 | dies_ok { $foo->set_h1( x => 'foo' ) } "h1 - can't set wrong type"; |
29dcbf33 |
84 | |
85 | is_deeply( $foo->h1, {}, "h1 - correct contents" ); |
86 | |
87 | $foo->set_h1( x => 1 ); |
88 | is_deeply( $foo->h1, { x => 1 }, "h1 - correct contents" ); |
89 | } |
90 | |
91 | { |
53a4d826 |
92 | dies_ok { $foo->set_h2('foo') } "h2 - can't set onto undef"; |
29dcbf33 |
93 | |
94 | $foo->h2( {} ); |
95 | is_deeply( $foo->h2, {}, "h2 - correct contents" ); |
96 | |
97 | $foo->set_h2( x => 'foo' ); |
98 | is_deeply( $foo->h2, { x => 'foo' }, "h2 - correct contents" ); |
99 | |
53a4d826 |
100 | dies_ok { $foo->set_h2( y => 'bar' ) } |
29dcbf33 |
101 | "h2 - can't set more than one element"; |
102 | |
103 | is_deeply( $foo->h2, { x => 'foo' }, "h2 - correct contents" ); |
104 | } |
105 | |
106 | { |
53a4d826 |
107 | dies_ok { $foo->set_h3(1) } "h3 - can't set onto undef"; |
29dcbf33 |
108 | |
109 | $foo->h3( {} ); |
110 | is_deeply( $foo->h3, {}, "h3 - correct contents" ); |
111 | |
53a4d826 |
112 | dies_ok { $foo->set_h3( x => 'foo' ) } "h3 - can't set non-int"; |
29dcbf33 |
113 | |
53a4d826 |
114 | dies_ok { $foo->set_h3( x => 100 ) } |
29dcbf33 |
115 | "h3 - can't violate overall type constraint"; |
116 | |
117 | is_deeply( $foo->h3, {}, "h3 - correct contents" ); |
118 | |
119 | $foo->set_h3( x => 1 ); |
120 | is_deeply( $foo->h3, { x => 1 }, "h3 - correct contents" ); |
121 | |
53a4d826 |
122 | dies_ok { $foo->set_h3( x => 100 ) } |
29dcbf33 |
123 | "h3 - can't violate overall type constraint"; |
124 | |
125 | is_deeply( $foo->h3, { x => 1 }, "h3 - correct contents" ); |
126 | |
127 | $foo->set_h3( y => 3 ); |
128 | is_deeply( $foo->h3, { x => 1, y => 3 }, "h3 - correct contents" ); |
129 | } |
130 | |
131 | done_testing; |