File Coverage

blib/lib/Chess/PGN/Extract.pm

Criterion	Covered	Total	%
statement	33	65	50.7
branch	0	8	0.0
condition			n/a
subroutine	11	14	78.5
pod	1	1	100.0
total	45	88	51.1

package Chess::PGN::Extract;
use 5.008001;
use strict;
use warnings;

our $VERSION = '0.02';

use base 'Exporter::Tiny';
our @EXPORT = qw| read_games |;

use Carp       qw| carp croak |;
use Data::Dump qw| dump |;
use Encode     qw| encode_utf8 |;
use IO::Handle;
use JSON::XS   qw| decode_json |;
use Sys::Cmd   qw| spawn |;
use Try::Tiny;

sub read_games {
  my $pgn  = shift;
  my %opts = @_;
  # TODO: add options to be passed to pgn-extract

  my $proc = spawn ( 'pgn-extract', '-s', '-Wjson', $pgn );
  my $out = do { local $/; $proc->stdout->getline };
  my @err = $proc->stderr->getlines;
  if (@err) {
    if ($err[0] =~ /Unknown output format json/) {
      croak ("PGN parse error: pgn-extract has no '-Wjson' option");
    }
    STDERR->print ("pgn-extract: $_") for @err;
  }
  $proc->wait_child; # cleanup

  # Ad-hoc hack for a problem in parsing JSON
  #
  # PGN files may contain illegal characters and it hinders decoding by
  # JSON::XS. At present, I've found the control 'B' and back quote in
  # practice.
  if ( $out =~ s/[\cB\\]//g ) {
    STDERR->print ("Invalid characters found\n");
  }

  $out = encode_utf8 ($out);
  $out =~ s/\n//g;
  $out =~ s/}/},/g;
  chop $out;
  $out = "[" . $out . "]";

  my $decoded = try {
    decode_json ($out);
  } catch {
    croak ("JSON parse error: $out");
  };

  # Filter valid PGNs
  my @games = grep {
    if ( $_->{chash} ) {
      1;
    }
    else {
      my $invalid_game = dump ($_);
      STDERR->print ("Invalid PGN omitted: $invalid_game\n");
      0;
    }
  } @$decoded;

  foreach (@games) {
    delete $_->{chash};
    delete $_->{fhash};
  }

  return @games;
}

1;
__END__