Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Newer
Older
100644 309 lines (269 sloc) 7.873 kb
ff3b641 [gsoc_spectest] moved given.t to spec/, cleaned up syntax, fudged for ra...
Auzon authored
1 use v6;
2
3 use Test;
4
5 plan 48;
6
7 =begin pod
8
9 Tests the given block, as defined in L<S04/"Switch statements">
10
11 =end pod
12
13 {
14 # basic sanity
15 my ($t, $f);
16
17 try { given 1 { when 1 { $t = 1 } } };
18 ok($t, "given when true ...");
19
20 try { given 1 { when 2 { $f = 1 } } };;
21 ok(!$f, "given when false");
22 };
23
24 #?rakudo skip 'continue not implemented'
25 {
26 # simple case, with fall through
27 # L<S04/Switch statements/If the smart match fails, control passes to the next statement>
28 my ($two, $five, $int, $unreached);
29
30 given 5 {
31 when 2 { $two = 1 }
32 when 5 { $five = 1; continue }
33 when Int { $int = 1 }
34 when 5 { $unreached = 1 }
35 }
36
37 ok(!$two, "5 is not two");
38 ok($five, "5 is five");
39 ok($int, "short fell-through to next true when using 'continue'");
40 ok(!$unreached, "but didn't do so normally");
41 };
42
43 #?rakudo skip 'parsefail on regex'
44 {
45 my $foo;
46 given "foo" {
47 when "foo" {
48 when /^f/ {
49 $foo = 1
50 }
51 }
52 }
53
54 ok($foo, "foo was found in nested when");
55 };
56
57
58 # from apocalypse 4
59 #?rakudo skip 'parsefail on each(... ; ...)'
60 {
61 # simple example L<S04/"Switch statements" /You don't have to use an explicit default/>
62 for each(("T", "E", 5) ; (10, 11, 5)) -> $digit, $expected {
63 my $result_a = do given $digit {
64 when "T" { 10 }
65 when "E" { 11 }
66 $digit
67 };
68
69 my $result_b = do given $digit {
70 when "T" { 10 }
71 when "E" { 11 }
72 default { $digit }
73 };
74
75 is($result_a, $expected, "result of $digit using implicit default {} is $expected");
76 is($result_b, $expected, "result of $digit using explicit default {} is $expected");
77 }
78 }
79
80 {
81 # interleaved code L<S04/"Switch statements" /which may or may not be a when statement/>
82 my ($b_one, $b_two, $b_three, $panic);
83 given 2 {
84 $b_one = 1;
85 when 1 { }
86 $b_two = 1;
87 when 2 { }
88 $b_three = 1;
89 default { }
90 $panic = 1;
91 }
92
93 ok($b_one, "interleaved 1");
94 ok($b_two, "interleaved 2 is the last one");
95 #?rakudo 2 todo 'exiting given block happens at the wrong time'
96 ok(!$b_three, "inteleraved 3 not executed");
97 ok(!$panic, 'never ever execute something after a default {}');
98 };
99
100 #?rakudo skip 'my($a, $b, $c) = (1, 2, 3) parsefail'
101 {
102 # topic not given by 'given' L<S04/"Switch statements" /including a for loop/>
103 my ($b_one, $b_two, $b_three,$panic) = (0,0,0,0);
104 for (<1 2 3>) {
105 when 1 {$b_one = 1}
106 when 2 {$b_two = 1}
107 when 3 {$b_three = 1}
108 default {$panic =1}
109 }
110 ok($b_one, "first iteration");
111 ok($b_two, "second iteration");
112 ok($b_three, "third iteration");
113 ok(!$panic,"should not fall into default in this case");
114 }
115
116 {
117 my $foo = 1;
118 given (1) {
119 my $_ = 2;
120 when (2) { $foo = 2; }
121 when (1) { $foo = 3; }
122 default { $foo = 4; }
123 }
124 #?rakudo todo 'changing $_ does not work within given block'
125 is($foo, 2, 'Rebind $_ to new lexical');
126 }
127
128 #?rakudo skip 'my($a, $b, $c) = (1, 2, 3) parsefail'
129 {
130 my ($foo, $bar) = (1, 0);
131 given (1) {
132 when (1) { $foo = 2; continue; $foo = 3; }
133 when (2) { $foo = 4; }
134 default { $bar = 1; }
135 $foo = 5;
136 };
137 is($foo, 2, 'continue aborts when block');
138 ok($bar, 'continue does not prevent default');
139 }
140
141 #?rakudo skip 'my($a, $b, $c) = (1, 2, 3) parsefail'
142 {
143 my ($foo, $bar) = (1, 0);
144 given (1) {
145 when (1) { $foo = 2; break; $foo = 3; }
146 when (2) { $foo = 4; }
147 default { $bar = 1 }
148 $foo = 5;
149 };
150 is($foo, 2, 'break aborts when');
151 ok(!$bar, 'break prevents default');
152 }
153
154 #?rakudo skip 'my($a, $b, $c) = (1, 2, 3) parsefail'
155 {
156 my ($foo, $bar, $baz, $bad) = (0, 0, -1, 0);
157 my $quux = 0;
158 for 0, 1, 2 {
159 when 0 { $foo++; continue }
160 when 1 { $bar++; break }
161 when 2 { $quux++; }
162 default { $baz = $_ }
163 $bad = 1;
164 };
165 is($foo, 1, 'first iteration');
166 is($bar, 1, 'second iteration');
167 is($baz, 0, 'continue worked');
168 is($quux, 1, "break didn't abort loop");
169 ok(!$bad, "didn't fall through");
170 }
171
172
173 # given returns the correct value:
174 {
175 sub ret_test($arg) {
176 given $arg {
177 when "a" { "A" }
178 when "b" { "B" }
179 }
180 }
181
182 #?rakudo todo 'given does not return the correct value'
183 is( ret_test("a"), "A", "given returns the correct value (1)" );
184 is( ret_test("b"), "B", "given returns the correct value (2)" );
185 }
186
187 # given/when and junctions
188 {
189 my $any = 0;
190 my $all = 0;
191 my $one = 0;
192 given 1 {
193 when any(1 .. 3) { $any = 1; }
194 }
195 given 1 {
196 when all(1) { $all = 1; }
197 }
198 given 1 {
199 when one(1) { $one = 1; }
200 }
201 is($any, 1, 'when any');
202 is($all, 1, 'when all');
203 #?rakudo todo 'junctions with one'
204 is($one, 1, 'when one');
205 }
206
207 # given + objects
208 {
209 class TestIt { method passit { 1; }; has %.testing is rw; };
210 my $passed = 0;
211 ok( eval('given TestIt.new { $_.passit; };'), '$_. method calls' );
212 ok( eval('given TestIt.new { .passit; };'), '. method calls' );
213 #?rakudo 2 skip 'Null PMC access in type'
214 ok( eval('given TestIt.new { $_.testing<a> = 1; };'),'$_. attribute access' );
215 ok( eval('given TestIt.new { .testing<a> = 1; };'), '. attribute access' );
216 my $t = TestIt.new;
217 given $t { when TestIt { $passed = 1;} };
218 is($passed, 1,"when Type {}");
219 $passed = 0;
220 #?rakudo emit # the line below dies
221 given $t { when .isa(TestIt) { $passed = 1;}};
222 #?rakudo 1 todo 'get_number() not implemented in class "TestIt"'
223 is($passed, 1,'when .isa(Type) {}');
224 $passed = 0;
225 given $t { when (TestIt) { $passed = 1; }};
226 is($passed, 1,'when (Type) {}');
227 }
228
229 # given + true
230 # L<S04/"Switch statements" /"is exactly equivalent to">
231 my @input = (0, 1);
232 my @got;
233
234 for @input -> $x {
235 given $x {
236 when .true { push @got, "true" }
237 default { push @got, "false" }
238 }
239 }
240
241 #?rakudo 1 todo '.true in given does not work'
242 is(@got.join(","), "false,true", 'given { when .true { } }');
243
244 # given + hash deref
245 #?rakudo skip 'parsefail on .{"key"} when $_ is a hash'
246 {
247 my %h;
248 given %h { .{'key'} = 'value'; }
249 ok(%h{'key'} eq 'value', 'given and hash deref using .{}');
250 given %h { .<key> = "value"; }
251 ok(%h{'key'} eq 'value', 'given and hash deref using .<>');
252 }
253
254 # given + 0-arg closure
255 {
256 my $x;
257 given 41 {
258 when ({ $_ == 49 }) { diag "this really shouldn't happen"; $x = 49 }
259 when ({ $_ == 41 }) { $x++ }
260 }
261 #?rakudo todo 'testing closure does not work'
262 ok $x, 'given tests 0-arg closures for truth';
263 }
264
265 # given + 1-arg closure
266 #?rakudo skip 'parsefail (-> $var {block})'
267 {
268 my $x;
269 given 41 {
270 when (-> $t { $t == 49 }) { diag "this really shouldn't happen"; $x = 49 }
271 when (-> $t { $t == 41 }) { $x++ }
272 }
273 ok $x, 'given tests 1-arg closures for truth';
274 }
275
276 # given + n>1-arg closure (should fail)
277 #?rakudo skip 'parsefail (-> $var {block})'
278 {
279 dies_ok {
280 given 41 {
281 when (-> $t, $r { $t == $r }) { ... }
282 }
283 }, 'fail on arities > 1';
284 is $!, 'Unexpected arity in smart match: 2', '...with useful error message';
285 }
286
287 # given + 0-arg sub
288 #?rakudo skip 'parsefail (when &sub {block})'
289 {
290 my $x = 41;
291 sub always_true { Bool::True }
292 given 1 {
293 when &always_true { $x++ }
294 }
295 is $x, 42, 'given tests 0-arg subs for truth';
296 }
297
298 # given + 1-arg sub
299 #?rakudo skip 'parsefail (when &sub {block})'
300 {
301 my $x = 41;
302 sub maybe_true ($value) { $value eq "mytopic" }
303 given "mytopic" {
304 when &maybe_true { $x++ }
305 }
306 is $x, 42, 'given tests 1-arg subs for truth';
307 }
308
Something went wrong with that request. Please try again.