Commit | Line | Data |
b2b106d7 |
1 | #!/usr/bin/perl |
c47cf415 |
2 | # This is automatically generated by author/import-moose-test.pl. |
3 | # DO NOT EDIT THIS FILE. ANY CHANGES WILL BE LOST!!! |
4 | use t::lib::MooseCompat; |
b2b106d7 |
5 | |
6 | use strict; |
7 | use warnings; |
8 | |
c47cf415 |
9 | use Test::More; |
10 | $TODO = q{Mouse is not yet completed}; |
b2b106d7 |
11 | use Test::Exception; |
12 | |
13 | use Mouse::Util::TypeConstraints; |
14 | |
15 | # some simple type dispatching ... |
16 | |
17 | subtype 'Null' |
18 | => as 'ArrayRef' |
19 | => where { scalar @{$_} == 0 }; |
20 | |
21 | sub head { |
22 | match_on_type @_ => |
23 | Null => sub { die "Cannot get the head of Null" }, |
24 | ArrayRef => sub { $_->[0] }; |
25 | } |
26 | |
27 | sub tail { |
28 | match_on_type @_ => |
29 | Null => sub { die "Cannot get the tail of Null" }, |
30 | ArrayRef => sub { [ @{ $_ }[ 1 .. $#{ $_ } ] ] }; |
31 | } |
32 | |
33 | sub len { |
34 | match_on_type @_ => |
35 | Null => sub { 0 }, |
36 | ArrayRef => sub { len( tail( $_ ) ) + 1 }; |
37 | } |
38 | |
39 | sub rev { |
40 | match_on_type @_ => |
41 | Null => sub { [] }, |
42 | ArrayRef => sub { [ @{ rev( tail( $_ ) ) }, head( $_ ) ] }; |
43 | } |
44 | |
45 | is( len( [] ), 0, '... got the right length'); |
46 | is( len( [ 1 ] ), 1, '... got the right length'); |
47 | is( len( [ 1 .. 5 ] ), 5, '... got the right length'); |
48 | is( len( [ 1 .. 50 ] ), 50, '... got the right length'); |
49 | |
50 | is_deeply( |
51 | rev( [ 1 .. 5 ] ), |
52 | [ reverse 1 .. 5 ], |
53 | '... got the right reversed value' |
54 | ); |
55 | |
56 | # break down a Maybe Type ... |
57 | |
58 | sub break_it_down { |
59 | match_on_type shift, |
60 | 'Maybe[Str]' => sub { |
61 | match_on_type $_ => |
62 | 'Undef' => sub { 'undef' }, |
63 | 'Str' => sub { $_ } |
64 | }, |
65 | sub { 'default' } |
66 | } |
67 | |
68 | |
69 | is( break_it_down( 'FOO' ), 'FOO', '... got the right value'); |
70 | is( break_it_down( [] ), 'default', '... got the right value'); |
71 | is( break_it_down( undef ), 'undef', '... got the right value'); |
72 | is( break_it_down(), 'undef', '... got the right value'); |
73 | |
74 | # checking against enum types |
75 | |
76 | enum RGB => qw[ red green blue ]; |
77 | enum CMYK => qw[ cyan magenta yellow black ]; |
78 | |
79 | sub is_acceptable_color { |
80 | match_on_type shift, |
81 | 'RGB' => sub { 'RGB' }, |
82 | 'CMYK' => sub { 'CMYK' }, |
83 | sub { die "bad color $_" }; |
84 | } |
85 | |
86 | is( is_acceptable_color( 'blue' ), 'RGB', '... got the right value'); |
87 | is( is_acceptable_color( 'green' ), 'RGB', '... got the right value'); |
88 | is( is_acceptable_color( 'red' ), 'RGB', '... got the right value'); |
89 | is( is_acceptable_color( 'cyan' ), 'CMYK', '... got the right value'); |
90 | is( is_acceptable_color( 'magenta' ), 'CMYK', '... got the right value'); |
91 | is( is_acceptable_color( 'yellow' ), 'CMYK', '... got the right value'); |
92 | is( is_acceptable_color( 'black' ), 'CMYK', '... got the right value'); |
93 | |
94 | dies_ok { |
95 | is_acceptable_color( 'orange' ) |
96 | } '... got the exception'; |
97 | |
98 | ## using it in an OO context |
99 | |
100 | { |
101 | package LinkedList; |
102 | use Mouse; |
103 | use Mouse::Util::TypeConstraints; |
104 | |
105 | has 'next' => ( |
106 | is => 'ro', |
107 | isa => __PACKAGE__, |
108 | lazy => 1, |
109 | default => sub { __PACKAGE__->new }, |
110 | predicate => 'has_next' |
111 | ); |
112 | |
113 | sub pprint { |
114 | my $list = shift; |
115 | match_on_type $list => |
116 | subtype( |
117 | as 'LinkedList', |
118 | where { ! $_->has_next } |
119 | ) => sub { '[]' }, |
120 | 'LinkedList' => sub { '[' . $_->next->pprint . ']' }; |
121 | } |
122 | } |
123 | |
124 | my $l = LinkedList->new; |
125 | is($l->pprint, '[]', '... got the right pprint'); |
126 | $l->next; |
127 | is($l->pprint, '[[]]', '... got the right pprint'); |
128 | $l->next->next; |
129 | is($l->pprint, '[[[]]]', '... got the right pprint'); |
130 | $l->next->next->next; |
131 | is($l->pprint, '[[[[]]]]', '... got the right pprint'); |
132 | |
133 | # basic data dumper |
134 | |
135 | { |
136 | package Foo; |
137 | use Mouse; |
138 | |
139 | sub to_string { 'Foo()' } |
140 | } |
141 | |
142 | use B; |
143 | |
144 | sub ppprint { |
145 | my $x = shift; |
146 | match_on_type $x => |
147 | HashRef => sub { |
148 | my $hash = shift; |
149 | '{ ' . (join ", " => map { |
150 | $_ . ' => ' . ppprint( $hash->{ $_ } ) |
151 | } sort keys %$hash ) . ' }' }, |
152 | ArrayRef => sub { |
153 | my $array = shift; |
154 | '[ ' . (join ", " => map { ppprint( $_ ) } @$array ) . ' ]' }, |
155 | CodeRef => sub { 'sub { ... }' }, |
156 | RegexpRef => sub { 'qr/' . $_ . '/' }, |
157 | GlobRef => sub { '*' . B::svref_2object($_)->NAME }, |
158 | Object => sub { $_->can('to_string') ? $_->to_string : $_ }, |
159 | ScalarRef => sub { '\\' . ppprint( ${$_} ) }, |
160 | Num => sub { $_ }, |
161 | Str => sub { '"'. $_ . '"' }, |
162 | Undef => sub { 'undef' }, |
163 | => sub { die "I don't know what $_ is" }; |
164 | } |
165 | |
166 | is( |
167 | ppprint( |
168 | { |
169 | one => [ 1, 2, "three", 4, "five", \(my $x = "six") ], |
170 | two => undef, |
171 | three => sub { "OH HAI" }, |
172 | four => qr/.*?/, |
173 | five => \*ppprint, |
174 | six => Foo->new, |
175 | } |
176 | ), |
177 | '{ five => *ppprint, four => qr/(?-xism:.*?)/, one => [ 1, 2, "three", 4, "five", \"six" ], six => Foo(), three => sub { ... }, two => undef }', |
178 | '... got the right pretty printed values' |
179 | ); |
180 | |
181 | # simple JSON serializer |
182 | |
183 | sub to_json { |
184 | my $x = shift; |
185 | match_on_type $x => |
186 | HashRef => sub { |
187 | my $hash = shift; |
188 | '{ ' . (join ", " => map { |
189 | '"' . $_ . '" : ' . to_json( $hash->{ $_ } ) |
190 | } sort keys %$hash ) . ' }' }, |
191 | ArrayRef => sub { |
192 | my $array = shift; |
193 | '[ ' . (join ", " => map { to_json( $_ ) } @$array ) . ' ]' }, |
194 | Num => sub { $_ }, |
195 | Str => sub { '"'. $_ . '"' }, |
196 | Undef => sub { 'null' }, |
197 | => sub { die "$_ is not acceptable json type" }; |
198 | } |
199 | |
200 | is( |
201 | to_json( { one => 1, two => 2 } ), |
202 | '{ "one" : 1, "two" : 2 }', |
203 | '... got our valid JSON' |
204 | ); |
205 | |
206 | is( |
207 | to_json( { |
208 | one => [ 1, 2, 3, 4 ], |
209 | two => undef, |
210 | three => "Hello World" |
211 | } ), |
212 | '{ "one" : [ 1, 2, 3, 4 ], "three" : "Hello World", "two" : null }', |
213 | '... got our valid JSON' |
214 | ); |
215 | |
216 | |
217 | # some error cases |
218 | |
219 | sub not_enough_matches { |
220 | my $x = shift; |
221 | match_on_type $x => |
222 | Undef => sub { 'hello undef world' }, |
223 | CodeRef => sub { $_->('Hello code ref world') }; |
224 | } |
225 | |
226 | throws_ok { |
227 | not_enough_matches( [] ) |
228 | } qr/No cases matched for /, '... not enough matches'; |
229 | |
c47cf415 |
230 | done_testing; |