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