File Coverage

blib/lib/Chess/PGN/Extract.pm
Criterion Covered Total %
statement 33 63 52.3
branch 0 6 0.0
condition n/a
subroutine 11 14 78.5
pod 1 1 100.0
total 45 84 53.5


line stmt bran cond sub pod time code
1             package Chess::PGN::Extract;
2 3     3   17228 use 5.008001;
  3         11  
  3         112  
3 3     3   14 use strict;
  3         3  
  3         94  
4 3     3   22 use warnings;
  3         4  
  3         149  
5              
6             our $VERSION = '0.01';
7              
8 3     3   12 use base 'Exporter::Tiny';
  3         5  
  3         1432  
9             our @EXPORT = qw| read_games |;
10              
11 3     3   4852 use Carp qw| carp croak |;
  3         5  
  3         167  
12 3     3   1451 use Data::Dump qw| dump |;
  3         15225  
  3         206  
13 3     3   1645 use Encode qw| encode_utf8 |;
  3         24216  
  3         268  
14 3     3   1222 use IO::Handle;
  3         10523  
  3         125  
15 3     3   1865 use JSON::XS qw| decode_json |;
  3         13422  
  3         185  
16 3     3   1432 use Sys::Cmd qw| spawn |;
  3         51455  
  3         22  
17 3     3   1878 use Try::Tiny;
  3         3448  
  3         1061  
18              
19             sub read_games {
20 0     0 1   my $pgn = shift;
21 0           my %opts = @_;
22             # TODO: add options to be passed to pgn-extract
23              
24 0           my $proc = spawn ( 'pgn-extract', '-s', '-Wjson', $pgn );
25 0           my $out = do { local $/; $proc->stdout->getline };
  0            
  0            
26 0           my @err = $proc->stderr->getlines;
27 0 0         if (@err) {
28 0           print STDERR "pgn-extract: $_" for @err;
29             }
30 0           $proc->wait_child; # cleanup
31              
32             # Ad-hoc hack for a problem in parsing JSON
33             #
34             # PGN files may contain illegal characters and it hinders decoding by
35             # JSON::XS. At present, I've found the control 'B' and back quote in
36             # practice.
37 0 0         if ( $out =~ s/[\cB\\]//g ) {
38 0           print STDERR "Invalid characters found\n";
39             }
40              
41 0           $out = encode_utf8 ($out);
42 0           $out =~ s/\n//g;
43 0           $out =~ s/}/},/g;
44 0           chop $out;
45 0           $out = "[" . $out . "]";
46              
47             my $decoded = try {
48 0     0     decode_json ($out);
49             } catch {
50 0     0     croak ("JSON parse error: $out");
51 0           };
52              
53             # Filter valid PGNs
54             my @games = grep {
55 0 0         if ( $_->{chash} ) {
  0            
56 0           1;
57             }
58             else {
59 0           my $invalid_game = dump ($_);
60 0           print STDERR "Invalid PGN omitted: $invalid_game\n";
61 0           0;
62             }
63             } @$decoded;
64              
65 0           foreach (@games) {
66 0           delete $_->{chash};
67 0           delete $_->{fhash};
68             }
69              
70 0           return (@games);
71             }
72              
73             1;
74             __END__