3 # This file is part of Language::Befunge.
4 # Copyright (c) 2001-2009 Jerome Quelin, all rights reserved.
6 # This program is free software; you can redistribute it and/or modify
7 # it under the same terms as Perl itself.
12 # Language::Befunge::Storage tests for Generic Sparse plugin
19 use Test::More tests => 95;
21 use aliased 'Language::Befunge::Storage::Generic::Sparse' => 'Storage';
22 use Language::Befunge::Wrapping::LaheySpace;
23 use aliased 'Language::Befunge::Vector' => 'LBV';
24 use List::Util qw{ max };
27 # vars used within the file
28 my ($href, $l, $s, $str, $v);
29 my $str1 = 'Foobar baz'; my $lstr1 = length $str1;
30 my $str2 = 'camel llama'; my $lstr2 = length $str2;
31 my $wrap = Language::Befunge::Wrapping::LaheySpace->new();
37 $s = Storage->new(2, Wrapping => $wrap);
38 isa_ok($s, 'Language::Befunge::Storage');
39 isa_ok($s, 'Language::Befunge::Storage::Generic::Sparse');
40 is($s->min, '(0,0)', 'new() initializes storage');
41 is($s->max, '(0,0)', 'new() initializes storage');
42 is($s->get_dims, 2, 'get_dims() returns the number passed to new()');
48 $s = Storage->new(2, Wrapping => $wrap);
49 $s->store($str1, LBV->new(-2,-2));
50 $s->store($str1, LBV->new( 2, 2));
52 is($s->min, '(0,0)', 'clear() reinits min bounds');
53 is($s->max, '(0,0)', 'clear() reinits max bounds');
54 is($s->get_value(LBV->new(2,2)), 32, 'clear() clears previous data');
58 $s = Storage->new(2, Wrapping => $wrap);
60 # basic store_binary(), defaulting to origin
61 $s->store_binary( $str1 );
63 # 5432101234567890123456789012345678
68 is($s->min, '(0,0)', 'store_binary() does not grow min bounds if not needed');
69 is($s->max, '(9,0)', 'store_binary() grows max bounds if needed');
70 is($s->rectangle(LBV->new(0,0), LBV->new($lstr1,1)), $str1, 'store_binary() stores everything');
71 is($s->min, '(0,0)', 'rectangle() does not unnecessarily expand the array');
72 is($s->max, '(9,0)', 'rectangle() does not unnecessarily expand the array');
73 is($s->get_value(LBV->new(-1,0)), 32, 'store_binary() does not spill');
74 is($s->get_value(LBV->new(10,0)), 32, 'store_binary() does not spill');
75 is($s->min, '(0,0)', 'get_value() does not unnecessarily expand the array');
76 is($s->max, '(9,0)', 'get_value() does not unnecessarily expand the array');
78 # store_binary() with a positive offset
79 $s->store_binary( $str1, LBV->new(4,2) );
81 # 5432101234567890123456789012345678
88 is($s->min, '(0,0)', 'store_binary() does not grow min bounds if not needed');
89 is($s->max, '(13,2)', 'store_binary() grows max bounds if needed');
90 is($s->rectangle(LBV->new(4,2), LBV->new($lstr1,1)), $str1, 'store_binary() stores everything');
91 is($s->get_value(LBV->new( 3,2)), 32, 'store_binary() does not spill');
92 is($s->get_value(LBV->new(14,2)), 32, 'store_binary() does not spill');
94 # store_binary() with a negative offset
95 $s->store_binary( $str1, LBV->new(-2,-1) );
97 # 5432101234567890123456789012345678
104 is($s->min, '(-2,-1)', 'store_binary() grows min bounds if needed');
105 is($s->max, '(13,2)', 'store_binary() does not grow max bounds if not needed');
106 is($s->rectangle(LBV->new(-2,-1), LBV->new($lstr1,1)), $str1, 'store_binary() stores everything');
107 is($s->get_value(LBV->new(-3,-1)), 32, 'store_binary() does not spill');
108 is($s->get_value(LBV->new( 8,-1)), 32, 'store_binary() does not spill');
110 # store_binary() overwriting
111 $s->store_binary( $str2, LBV->new(2,0) );
113 # 5432101234567890123456789012345678
120 is($s->get_value(LBV->new(2,0)), 99, 'store_binary() overwrites non-space');
121 is($s->get_value(LBV->new(7,0)), 98, 'store_binary() does not overwrite with spaces');
123 # store_binary() returns the size inserted
124 $v = $s->store_binary( $str1 );
125 is($v, "($lstr1,1)", 'store_binary() returns the inserted size');
127 # store_binary() does not treat end of lines as such (crlf / lf / cr)
129 $str = "$str1\n$str2"; $l = length $str;
130 $v = $s->store_binary( $str );
131 is($v, "($l,1)", 'store_binary() does not treat \n as special');
133 $str = "$str1\r\n$str2"; $l = length $str;
134 $v = $s->store_binary( $str );
135 is($v, "($l,1)", 'store_binary() does not treat \r\n as special');
137 $str = "$str1\r$str2"; $l = length $str;
138 $v = $s->store_binary( $str );
139 is($v, "($l,1)", 'store_binary() does not treat \r as special');
143 $s = Storage->new(2, Wrapping => $wrap);
145 # basic store(), defaulting to origin
148 # 5432101234567890123456789012345678
153 is($s->min, '(0,0)', 'store() does not grow min bounds if not needed');
154 is($s->max, '(9,0)', 'store() grows max bounds if needed');
155 is($s->rectangle(LBV->new(0,0), LBV->new($lstr1,1)), $str1, 'store() stores everything');
156 is($s->get_value(LBV->new(-1,0)), 32, 'store() does not spill');
157 is($s->get_value(LBV->new(10,0)), 32, 'store() does not spill');
159 # store() with a positive offset
160 $s->store( $str1, LBV->new(4,2) );
162 # 5432101234567890123456789012345678
169 is($s->min, '(0,0)', 'store() does not grow min bounds if not needed');
170 is($s->max, '(13,2)', 'store() grows max bounds if needed');
171 is($s->rectangle(LBV->new(4,2), LBV->new($lstr1,1)), $str1, 'store() stores everything');
172 is($s->get_value(LBV->new( 3,2)), 32, 'store() does not spill');
173 is($s->get_value(LBV->new(14,2)), 32, 'store() does not spill');
175 # store() with a negative offset
176 $s->store( $str1, LBV->new(-2,-1) );
178 # 5432101234567890123456789012345678
185 is($s->min, '(-2,-1)', 'store() grows min bounds if needed');
186 is($s->max, '(13,2)', 'store() does not grow max bounds if not needed');
187 is($s->rectangle(LBV->new(-2,-1), LBV->new($lstr1,1)), $str1, 'store() stores everything');
188 is($s->get_value(LBV->new(-3,-1)), 32, 'store() does not spill');
189 is($s->get_value(LBV->new( 8,-1)), 32, 'store() does not spill');
191 # store() overwriting
192 $s->store( $str2, LBV->new(2,0) );
194 # 5432101234567890123456789012345678
201 is($s->get_value(LBV->new(2,0)), 99, 'store() overwrites non-space');
202 is($s->get_value(LBV->new(7,0)), 98, 'store() does not overwrite with spaces');
204 # store() returns the size inserted
205 $v = $s->store( "$str1\n $str2" );
206 $l = 4 + $lstr2; # 4 spaces before $str2
207 is($v, "($l,2)", 'store() returns the inserted size');
209 # store() supports various end of lines (crlf / lf / cr)
210 $l = max($lstr1, $lstr2);
212 $v = $s->store("$str1\n$str2");
213 is($v, "($l,2)", 'store() supports \n eol');
215 $v = $s->store( "$str1\r\n$str2" );
216 is($v, "($l,2)", 'store() supports \r\n eol');
218 $v = $s->store("$str1\r$str2");
219 is($v, "($l,2)", 'store() supports \r eol');
223 $s = Storage->new(2, Wrapping => $wrap);
224 # set_value() grows storage
225 $s->set_value(LBV->new(8,4), 65);
226 is($s->min, '(0,0)', 'set_value() does not grow min bounds if not needed');
227 is($s->max, '(8,4)', 'set_value() grows max bounds if needed');
228 $s->set_value(LBV->new(-2,-3), 65);
229 is($s->min, '(-2,-3)', 'set_value() grows min bounds if needed');
230 is($s->max, '(8,4)', 'set_value() does not grow max bounds if not needed');
231 # set_value() sets/overwrites new value
234 $s->set_value($v, 65);
235 is($s->get_value($v), 65, 'set_value() sets a new value');
236 $s->set_value($v, 66);
237 is($s->get_value($v), 66, 'set_value() overwrites with non-space values');
238 $s->set_value($v, 32);
239 is($s->get_value($v), 32, 'set_value() overwrites even with space values');
244 #- min() already tested plenty of time
245 #- max() already tested plenty of time
247 #- get_value() already tested plenty of time
248 # just need to test default value
249 $s = Storage->new(2, Wrapping => $wrap);
250 is($s->get_value(LBV->new(3,4)), 32, 'get_value() defaults to space');
255 $s = Storage->new(2, Wrapping => $wrap);
257 $s->set_value($v, 65);
258 is($s->get_char($v), 'A', 'get_char() return correct character');
260 is($s->get_char(LBV->new(3,2)), ' ', 'get_char() defaults to space');
262 $s->set_value($v, 9786); # smiley face
263 is($s->get_char($v), "<np-0x263a>", 'get_char() return correct character');
267 $s = Storage->new(2, Wrapping => $wrap);
268 $s->store($str1, LBV->new(-2,-2));
269 $s->store($str1, LBV->new(-1,-1));
270 $s->store($str1, LBV->new( 0, 0));
271 $s->store($str1, LBV->new( 1, 1));
272 $s->store($str1, LBV->new( 2, 2));
274 # 5432101234567890123456789012345678
281 is($s->rectangle(LBV->new(2,-1),LBV->new(5,1)), 'bar b', 'rectangle() returns correct data');
282 is($s->rectangle(LBV->new(2,-1),LBV->new(9,3)), "bar baz \nobar baz \noobar baz",
283 'rectangle() returns correct data even with newlines');
284 is($s->rectangle(LBV->new(19,1),LBV->new(5,1)), ' ', 'rectangle() returns correct data even with spaces');
286 is($s->rectangle(LBV->new(0,0),LBV->new(5,0)), '', 'rectangle() with no height returns empty string');
287 is($s->rectangle(LBV->new(0,0),LBV->new(0,5)), '', 'rectangle() with no width returns empty string');
293 $s = Storage->new(2, Wrapping => $wrap);
296 $s->store( <<'EOF', LBV->new(-2, -1 ));
312 $href = $s->labels_lookup;
313 isa_ok($href, 'HASH');
314 is(scalar(keys(%$href)), 4, 'labels_lookup() finds everything');
315 is($href->{foo}[0], '(10,5)', 'labels_lookup() finds left-right');
316 is($href->{bar}[0], '(-2,5)', 'labels_lookup() finds right-left');
317 is($href->{bar}[1], '(-1,0)', 'labels_lookup() deals with right-left');
318 is($href->{baz}[0], '(4,-1)', 'labels_lookup() finds bottom-top');
319 is($href->{baz}[1], '(0,-1)', 'labels_lookup() deals with bottom-top');
320 is($href->{blah}[0], '(4,12)', 'labels_lookup() finds top-bottom');
321 is($href->{blah}[1], '(0,1)', 'labels_lookup() deals with top-bottom');
325 $s->store( <<'EOF', LBV->new(-2, -1 ));
336 $href = $s->labels_lookup;
337 is(scalar(keys(%$href)), 4, 'labels_lookup() finds everything, even wrapping');
338 is($href->{foo}[0], '(-1,-1)', 'labels_lookup() finds left-right');
339 is($href->{foo}[1], '(1,0)', 'labels_lookup() deals with left-right');
340 is($href->{bar}[0], '(16,0)', 'labels_lookup() finds right-left');
341 is($href->{bar}[1], '(-1,0)', 'labels_lookup() deals with right-left');
342 is($href->{baz}[0], '(6,6)', 'labels_lookup() finds bottom-top');
343 is($href->{baz}[1], '(0,-1)', 'labels_lookup() deals with bottom-top');
344 is($href->{blah}[0], '(9,0)', 'labels_lookup() finds top-bottom');
345 is($href->{blah}[1], '(0,1)', 'labels_lookup() deals with top-bottom');
349 $s->store( <<'EOF', LBV->new(-2, -1 ));
353 $href = $s->labels_lookup;
354 is(scalar(keys(%$href)), 1, 'labels_lookup() does not get fooled by look-alike labels');
355 is($href->{foo}[0], '(14,-1)', 'labels_lookup() discards comments');
356 is($href->{foo}[1], '(1,0)', 'labels_lookup() discards comments');
360 $s->store( <<'EOF', LBV->new(-2, -1 ));
364 throws_ok(sub { $s->labels_lookup },
365 qr/^Help! I found two labels 'foo' in the funge space/,
366 'labels_lookup() chokes on double-defined labels');
369 # bad arguments to constructor
370 throws_ok(sub { Storage->new() }, qr/^Usage/, 'new chokes on undef dimensions');
371 throws_ok(sub { Storage->new(0) }, qr/^Usage/, 'new chokes on zero dimensions');
372 throws_ok(sub { Storage->new(1) }, qr/^Usage/, 'new chokes on null Wrapping');