File Coverage

lib/Games/Checkers/PDNParser.pm

Criterion	Covered	Total	%
statement	12	57	21.0
branch	0	28	0.0
condition	0	12	0.0
subroutine	4	7	57.1
pod	0	3	0.0
total	16	107	14.9

# Games::Checkers, Copyright (C) 1996-2012 Mikhael Goikhman, [e-mail]
#
# This program is free software: you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation, either version 3 of the License, or
# (at your option) any later version.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program.  If not, see .

use strict;
use warnings;

package Games::Checkers::PDNParser;

use Games::Checkers::LocationConversions;
use IO::File;

sub new ($$) {
	my $class = shift;
	my $filename = shift;

	-r "$filename.$_" and $filename .= ".$_"
		for qw(pdn.gz pdn.xz pdn.bz2 pdn gz xz bz2);
	my $file_to_open =
		$filename =~ /\.gz$/ ? "zcat $filename |" :
		$filename =~ /\.xz$/ ? "xzcat $filename |" :
		$filename =~ /\.bz2$/ ? "bzcat $filename |" :
		$filename;
	my $fd = new IO::File $file_to_open;
	die "Can't open PDN for reading ($filename)\n" unless $fd;

	my $self = { fn => $filename, fd => $fd, lineno => 0 };
	bless $self, $class;
	return $self;
}

sub error_prefix {
	my $self = shift;
	"Error parsing $self->{fn}, line $self->{lineno}, corrupted record:\n";
}

sub next_record ($) {
	my $self = shift;

	my $record_values = {};

	my $line;
	my $not_end = 0;
	while ($line = $self->{fd}->getline) {
		$self->{lineno}++;
		next if $line =~ /^\s*(([#;]|{.*}|\(.*\))\s*)?$/;
		$not_end = 1;
		if ($line =~ /\[(\w+)\s+"?(.*?)"?\]/) {
			$record_values->{$1} = $2;
			next;
		}
		last;
	}
	return undef unless $not_end;

	my $result = $record_values->{Result};
	die $self->error_prefix . "\tNon empty named value 'Result' is missing\n"
		unless $result;
	my $lineno = $self->{lineno};

	my $move_string = "";
	while (!$move_string || ($line = $self->{fd}->getline) && $self->{lineno}++) {
		$line =~ s/[\r\n]+$/ /;
		$move_string .= $line;
		last if $line =~ /$result/;

		# tolerate some broken PDNs without trailing result separator
		my $next_char = $self->{fd}->getc;
		$self->{fd}->ungetc(ord($next_char));
		last if $next_char eq "[";
	}

	# tolerate some broken PDNs without result separator
#	die $self->error_prefix . "\tSeparator ($result) is not found from line $lineno\n"
#		unless $line;

	$move_string =~ s/\b$result\b.*//;
	$move_string =~ s/{[^}]*}//g;  # remove comments
	$move_string =~ s/\([^\)]*(\)[^(]*)?\)//g;  # remove comments
	$move_string =~ s/([x:*-])\s+(\d|\w)/$1$2/gi;  # remove alignment spaces
	my @move_verge_strings = split(/(?:\s+|\d+\.\s*)+/, $move_string);
	shift @move_verge_strings while @move_verge_strings && !$move_verge_strings[0];

	my @move_verge_trios = map {
		/^((\d+)|\w\d)([x:*-])((\d+)|\w\d)$/i
			|| die $self->error_prefix . "\tIncorrect move notation ($_)\n";
		[
			$3 eq "-" ? 0 : 1,
			defined $2 ? num_to_location($1) : str_to_location($1),
			defined $5 ? num_to_location($4) : str_to_location($4),
		]
	} @move_verge_strings;

	return [ \@move_verge_trios, $record_values ];
}

1;