File Coverage

blib/lib/Games/LMSolve/Input.pm
Criterion Covered Total %
statement 82 160 51.2
branch 25 58 43.1
condition n/a
subroutine 7 16 43.7
pod 3 3 100.0
total 117 237 49.3


line stmt bran cond sub pod time code
1             package Games::LMSolve::Input;
2             $Games::LMSolve::Input::VERSION = '0.14.1';
3 2     2   15 use strict;
  2         4  
  2         66  
4 2     2   11 use warnings;
  2         4  
  2         425  
5              
6             package Games::LMSolve::Input::Scalar::FH;
7             $Games::LMSolve::Input::Scalar::FH::VERSION = '0.14.1';
8             sub TIEHANDLE
9             {
10 0     0   0 my $class = shift;
11 0         0 my $self = {};
12 0         0 my $buffer = shift;
13 0         0 $self->{'lines'} =
14             [ reverse( my @a = ( $buffer =~ /([^\n]*(?:\n|$))/sg ) ) ];
15 0         0 bless $self, $class;
16 0         0 return $self;
17             }
18              
19             sub READLINE
20             {
21 0     0   0 my $self = shift;
22 0         0 return pop( @{ $self->{'lines'} } );
  0         0  
23             }
24              
25             sub EOF
26             {
27 0     0   0 my $self = shift;
28 0         0 return ( scalar( @{ $self->{'lines'} } ) == 0 );
  0         0  
29             }
30              
31             package Games::LMSolve::Input;
32              
33 2     2   1019 use English qw/ -no_match_vars /;
  2         9465  
  2         13  
34              
35              
36             sub new
37             {
38 1     1 1 3 my $class = shift;
39              
40 1         2 my $self = {};
41              
42 1         3 bless $self, $class;
43              
44 1         4 $self->_initialize(@_);
45              
46 1         2 return $self;
47             }
48              
49             sub _initialize
50             {
51 1     1   3 my $self = shift;
52              
53 1         2 return 0;
54             }
55              
56              
57             sub input_board
58             {
59 1     1 1 2 my $self = shift;
60              
61 1         2 my $file_spec = shift;
62              
63 1         2 my $spec = shift;
64              
65 1         2 my $ret = {};
66              
67 1         2 my $file_ref;
68              
69 1         3 local (*I);
70              
71 1         2 my $filename_str;
72              
73 1 50       6 if ( ref($file_spec) eq "" )
    0          
    0          
74             {
75 1         2 my $filename = $file_spec;
76 1 50       36 open( my $in_fh, "<", $filename )
77             || die "Failed to read \"$filename\" : $OS_ERROR";
78              
79 1         4 $file_ref = $in_fh;
80 1 50       7 $filename_str =
81             ( $filename eq "-" )
82             ? "standard input"
83             : "\"$filename\"";
84             }
85             elsif ( ref($file_spec) eq "GLOB" )
86             {
87 0         0 $file_ref = $file_spec;
88 0         0 $filename_str = "FILEHANDLE";
89             }
90             elsif ( ref($file_spec) eq "SCALAR" )
91             {
92 0         0 tie( *I, "Games::LMSolve::Input::Scalar::FH", $$file_spec );
93 0         0 $file_ref = \*I;
94 0         0 $filename_str = "BUFFER";
95             }
96             else
97             {
98 0         0 die "Unknown file specification passed to input_board!";
99             }
100              
101             # Now we have the filehandle *$file_ref opened.
102              
103 1         3 my $line;
104 1         2 my $line_num = 0;
105              
106             my $read_line = sub {
107 11 100   11   15 if ( eof( *{$file_ref} ) )
  11         44  
108             {
109 1         6 return 0;
110             }
111 10         17 $line = readline( *{$file_ref} );
  10         19  
112 10         16 ++$line_num;
113 10         15 chomp($line);
114 10         21 return 1;
115 1         6 };
116              
117             my $gen_exception = sub {
118 0     0   0 my $text = shift;
119 0         0 close( *{$file_ref} );
  0         0  
120 0         0 die "$text on $filename_str at line $line_num!\n";
121 1         5 };
122              
123 1         3 my $xy_pair = "\\(\\s*(\\d+)\\s*\\,\\s*(\\d+)\\s*\\)";
124              
125 1         3 while ( $read_line->() )
126             {
127             # Skip if this is an empty line
128 4 100       17 if ( $line =~ /^\s*$/ )
129             {
130 1         3 next;
131             }
132              
133             # Check if we have a "key =" construct
134 3 50       13 if ( $line =~ /^\s*(\w+)\s*=/ )
135             {
136 3         10 my $key = lc($1);
137              
138             # Save the line number for safekeeping because a layout or
139             # other multi-line value can increase it.
140 3         6 my $key_line_num = $line_num;
141              
142 3 50       8 if ( !exists( $spec->{$key} ) )
143             {
144 0         0 $gen_exception->("Unknown key \"$key\"");
145             }
146 3 50       10 if ( exists( $ret->{$key} ) )
147             {
148 0         0 $gen_exception->("Key \"$key\" was already inputted!\n");
149             }
150              
151             # Strip anything up to and including the equal sign
152 3         13 $line =~ s/^.*?=\s*//;
153 3         7 my $type = $spec->{$key}->{'type'};
154 3         4 my $value;
155 3 50       18 if ( $type eq "integer" )
    100          
    50          
    100          
    50          
156             {
157 0 0       0 if ( $line =~ /^(\d+)\s*$/ )
158             {
159 0         0 $value = $1;
160             }
161             else
162             {
163 0         0 $gen_exception->(
164             "Key \"$key\" expects an integer as a value");
165             }
166             }
167             elsif ( $type eq "xy(integer)" )
168             {
169 1 50       6 if ( $line =~ /^\(\s*(\d+)\s*,\s*(\d+)\s*\)\s*$/ )
170             {
171 1         5 $value = { 'x' => $1, 'y' => $2 };
172             }
173             else
174             {
175 0         0 $gen_exception->(
176             "Key \"$key\" expects an (x,y) integral pair as a value"
177             );
178             }
179             }
180             elsif ( $type eq "array(xy(integer))" )
181             {
182              
183 0 0       0 if ( $line =~ /^\[\s*$xy_pair(\s*\,\s*$xy_pair)*\s*\]\s*$/ )
184             {
185 0         0 my @elements = ( $line =~ m/$xy_pair/g );
186 0         0 my @pairs;
187 0         0 while ( scalar(@elements) )
188             {
189 0         0 my $x = shift(@elements);
190 0         0 my $y = shift(@elements);
191 0         0 push @pairs, { 'x' => $x, 'y' => $y };
192             }
193 0         0 $value = \@pairs;
194             }
195             else
196             {
197 0         0 $gen_exception->(
198             "Key \"$key\" expects an array of integral (x,y) pairs as a value"
199             );
200             }
201             }
202             elsif ( $type eq "array(start_end(xy(integer)))" )
203             {
204 1         5 my $se_xy_pair = "\\(\\s*$xy_pair\\s*->\\s*$xy_pair\\s*\\)";
205 1 50       42 if ( $line =~
206             /^\[\s*$se_xy_pair(\s*\,\s*$se_xy_pair)*\s*\]\s*$/ )
207             {
208 1         26 my @elements = ( $line =~ m/$se_xy_pair/g );
209 1         3 my @pairs;
210 1         4 while ( scalar(@elements) )
211             {
212 4         11 my ( $sx, $sy, $ex, $ey ) = @elements[ 0 .. 3 ];
213 4         15 @elements = @elements[ 4 .. $#elements ];
214 4         18 push @pairs,
215             {
216             'start' => { 'x' => $sx, 'y' => $sy },
217             'end' => { 'x' => $ex, 'y' => $ey }
218             };
219             }
220 1         3 $value = \@pairs;
221             }
222             else
223             {
224 0         0 $gen_exception->(
225             "Key \"$key\" expects an array of integral (sx,sy) -> (ex,ey) start/end x,y pairs as a value"
226             );
227             }
228             }
229             elsif ( $type eq "layout" )
230             {
231 1 50       5 if ( $line =~ /^<<\s*(\w+)\s*$/ )
232             {
233 1         2 my $terminator = $1;
234 1         3 my @lines = ();
235 1         2 my $eof = 1;
236 1         2 while ( $read_line->() )
237             {
238 6 100       37 if ( $line =~ /^\s*$terminator\s*$/ )
239             {
240 1         2 $eof = 0;
241 1         3 last;
242             }
243 5         13 push @lines, $line;
244             }
245 1 50       4 if ($eof)
246             {
247 0         0 $gen_exception->(
248             "End of file reached before the terminator (\"$terminator\") for key \"$key\" was found"
249             );
250             }
251 1         4 $value = \@lines;
252             }
253             else
254             {
255 0         0 $gen_exception->(
256             "Key \"$key\" expects a layout specification (<
257             );
258             }
259             }
260             else
261             {
262 0         0 $gen_exception->("Unknown type \"$type\"!");
263             }
264              
265 3         13 $ret->{$key} = { 'value' => $value, 'line_num' => $key_line_num };
266             }
267             }
268              
269 1         2 close( *{$file_ref} );
  1         10  
270              
271 1         7 foreach my $key ( keys(%$spec) )
272             {
273 3 50       9 if ( $spec->{$key}->{'required'} )
274             {
275 3 50       8 if ( !exists( $ret->{$key} ) )
276             {
277 0         0 die
278             "The required key \"$key\" was not specified on $filename_str!\n";
279             }
280             }
281             }
282              
283 1         12 return $ret;
284             }
285              
286              
287             sub input_horiz_vert_walls_layout
288             {
289 0     0 1   my $self = shift;
290              
291 0           my $width = shift;
292 0           my $height = shift;
293 0           my $lines_ptr = shift;
294              
295 0           my ( @vert_walls, @horiz_walls );
296              
297 0           my $line;
298 0           my $line_num = 0;
299 0           my $y;
300              
301             my $get_next_line = sub {
302 0     0     my $ret = $lines_ptr->{'value'}->[$line_num];
303 0           ++$line_num;
304              
305 0           return $ret;
306 0           };
307              
308             my $gen_exception = sub {
309 0     0     my $msg = shift;
310             die(
311 0           $msg . " at line " . ( $line_num + $lines_ptr->{'line_num'} + 1 ) );
312 0           };
313              
314             my $input_horiz_wall = sub {
315 0     0     $line = $get_next_line->();
316 0 0         if ( length($line) != $width )
317             {
318 0           $gen_exception->("Incorrect number of blocks");
319             }
320 0 0         if ( $line =~ /([^ _\-])/ )
321             {
322 0           $gen_exception->("Incorrect character \'$1\'");
323             }
324             push @horiz_walls,
325 0 0         [ ( map { ( $_ eq "_" ) || ( $_ eq "-" ) } split( //, $line ) ) ];
  0            
326 0           };
327              
328             my $input_vert_wall = sub {
329 0     0     $line = $get_next_line->();
330 0 0         if ( length($line) != $width + 1 )
331             {
332 0           $gen_exception->("Incorrect number of blocks");
333             }
334 0 0         if ( $line =~ /([^ |])/ )
335             {
336 0           $gen_exception->("Incorrect character \'$1\'");
337             }
338 0           push @vert_walls, [ ( map { $_ eq "|" } split( //, $line ) ) ];
  0            
339 0           };
340              
341 0           for ( $y = 0 ; $y < $height ; $y++ )
342             {
343 0           $input_horiz_wall->();
344 0           $input_vert_wall->();
345             }
346 0           $input_horiz_wall->();
347              
348 0           return ( \@horiz_walls, \@vert_walls );
349             }
350              
351              
352             1;
353              
354             __END__