seperate class Data::StarCraft::PvPGN::Report

[perl/schtarr.git] / Data / StarCraft / PvPGN / Report.pm

diff --git a/Data/StarCraft/PvPGN/Report.pm b/Data/StarCraft/PvPGN/Report.pm
new file mode 100644 (file)
index 0000000..5b738ed
--- /dev/null
+++ b/Data/StarCraft/PvPGN/Report.pm
@@ -0,0 +1,72 @@
+package Data::StarCraft::PvPGN::Report;
+
+use strict;
+use warnings;
+use Carp;
+
+our $VERSION = "1.00";
+
+sub open {
+       my $package = shift;
+       my ($path) = @_;
+       open my $file, '<', $path or carp("No report file: $!\n"), return undef;
+       bless $file, $package;
+}
+
+sub head {
+       my $file = shift;
+       my %report;
+       while (defined ($_ = readline $file)) {
+               # empty line = end of head
+               /\S/ or last;
+               # strip first key=val pair
+               s{
+                       ^\s* ([a-zA-Z]+) = ("(?: [^"\\] | \\. )*" | \S*)
+               }{}x or chomp, warn("Unknown pvpgn report header line: $_\n"), next;
+               my ($key, $val) = ($1, $2);
+               $val =~ s/^"(.*)"$/$1/ and $val =~ s/\\(.)/$1/g;  # unquote
+               $report{$key} = $val;
+               redo if /\S/;  # other pairs on this line
+       }
+       return \%report;
+}
+
+sub players {
+       my $file = shift;
+       my @player;
+
+       while (defined ($_ = readline $file)) {
+               # ignore leading empty lines; stop if trailing
+               /\S/ or @player ? last : next;
+               my ($name, $result, $ladder) = /^ (\S+) \s+ ([A-Z]+) \s* (.*)/x
+                       or chomp, warn("Unknown pvpgn report player line: $_\n");
+               push @player, {name => $name, result => $result};
+               if ($ladder) {
+                       my @ladderdata = $ladder =~ m{
+                               ^ \s* rating=(\d+) \s+ \[\#\d+\]
+                               \s+ prob=([\d.]+)% \s+ K=(\d+) \s+ adj=([+-]\d+) \s* $
+                       }x ? $player[-1]{ladder} = {
+                               rating => $1,
+                               prob => $2,
+                               K => $3,
+                               adj => $4,
+                       } : warn("Unknown ladder details for player $name: $ladder\n");
+               }
+       }
+
+       my $i = -1;
+       while (defined ($_ = readline $file)) {
+               m{<race>([^<]+)</race>} or next;
+               while (1) {
+                       defined $player[++$i]
+                               or die("More <race> entries than $i found players\n");
+                       last unless $player[$i]->{result} eq "DISCONNECT";
+               }
+               $player[$i]->{race}= $1;
+       }
+
+       return \@player;
+}
+
+1;
+