--- /dev/null
+/Games/StarCraft/DB/Local.pm
--- /dev/null
+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;
+
--- /dev/null
+package Games::StarCraft::DB;
+
+use strict;
+use warnings;
+use DBIx::Simple;
+use Carp;
+use base 'DBIx::Simple';
+
+our $VERSION = '1.00';
+our @Conf; # database connect options
+
+sub connect {
+ my $self = shift;
+ eval { require Games::StarCraft::DB::Local }; # local @Conf overrides
+ my @options = @Conf;
+ if (@_ >= 1 and ref (my $manual = shift) eq "HASH") {
+ while (my ($key, $value) = each %$manual) {
+ $options[3]->{$key} = $value;
+ }
+ }
+ return $self->SUPER::connect(@options);
+}
+
+1;
+
--- /dev/null
+#!/bin/bash
+
+cd /var/log/pvpgn/reports
+ls -tgG | head -n 5 | tail -n 4 | nl
+psetreport=($(ls -t | head -n 4))
+read -ep 'report: ' report
+case "$report" in
+'')
+ echo "No report file; using replay only"
+ ;;
+[1-5])
+ report=${psetreport[$((report - 1))]}
+ echo "Report preset: $report"
+ ;;
+esac
+if [ -n "$report" ] && [ ! -r "$report" ]; then
+ echo "Report file $report not found"
+fi
+cd - > /dev/null
+echo
+
+read -p 'replay name: ' name
+if [ ! "$name" ]; then name=1x2; fi
+case "$name" in
+[0-9]*[a-z][a-z][1-9]x[1-9])
+ ago=${name:0:1}
+ name=${name:${#ago}}
+ name=$(date +%Y%m%d -d "$ago day ago")"$name"
+ echo "Only postfix specified; using $name"
+ ;;
+[1-9]x[1-9])
+ name=$(date +%Y%m%d)"bn$name"
+ echo "Only postfix specified; using $name"
+ ;;
+esac
+echo
+
+psetreplay=('shiar@shiar.demon.nl:sc.rep/replays')
+echo $psetreplay | nl
+read -p 'replay location: ' replay
+case "$replay" in
+*.rep) ;;
+1 | '')
+ replay="${psetreplay[0]}/$name.rep"
+ echo "Using preset replay location $replay"
+ ;;
+*)
+ replay="$replay/$name.rep"
+ echo Not ending in .rep; using $replay
+ ;;
+esac
+echo
+
+case "$replay" in
+http:*)
+ wget "$replay" -O "../replay/$name.rep"
+ ;;
+*@* | *:*)
+ scp -p "$replay" "../replay/$name.rep" || exit 1
+ ;;
+*)
+ cp -p "$replay" "../replay/$name.rep" || exit 1
+ ;;
+esac
+echo
+
+./screpextract ../replay/$name.rep | ./screp -a ../replay/$name.apm
+echo
+
+if [ -n "$report" ]; then
+ cp -ip "/var/log/pvpgn/reports/$report" "../replay/$name.txt" || exit 1
+ ./pvpgnreport ../replay/$name
+ read -p 'retype replay id? ' gameid
+ ./screpextract ../replay/$name.rep | ./screp -d $gameid
+else
+ read -p 'who won? ' winner
+ ./screpextract ../replay/$name.rep | ./screp -D ../replay/$name.rep "$winner"
+fi
+
+# UPDATE game SET speed = frames*.042 / extract('epoch' FROM COALESCE(duration, durationguess - '15 sec'));
+
use strict;
use warnings;
+use Data::StarCraft::PvPGN::Report;
use Data::Dumper;
+our $VERSION = '1.00';
+
our $DBG = 0;
our $TEST = 0;
-sub reporthead {
- my ($reportfile) = @_;
- my %report;
- while (defined ($_ = readline $reportfile)) {
- # 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 reportplayers {
- my ($reportfile) = @_;
- my @player;
-
- while (defined ($_ = readline $reportfile)) {
- # ignore leading empty lines; stop if trailing
- /\S/ or @player ? last : next;
- my ($name, $result) = /^ (.*?) \s+ ([A-Z]+) \s*$/x
- or chomp, warn("Unknown pvpgn report player line: $_\n");
- push @player, {name => $name, result => $result};
- }
-
- my $i = -1;
- while (defined ($_ = readline $reportfile)) {
- 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;
-}
+use Getopt::Long qw(:config bundling auto_version auto_help);
+GetOptions(
+ "verbose|v!" => \$DBG,
+ "test|t!" => \$TEST,
+);
-my $name = $ARGV[0] or die "Usage: $0 FILE\n";
-open my $reportfile, '<', "$name.txt" or die "No report file: $!\n";
-my $report = reporthead($reportfile);
-print Dumper $report if $DBG;
+my $path = $ARGV[0] or die "Usage: $0 FILE\n";
+my ($name) = $path =~ m{([^/]+)$};
+my $report = Data::StarCraft::PvPGN::Report->open("$path.txt")
+ or die "No report file: $!\n";
+my $data = $report->head;
+print Dumper $data if $DBG;
-my $players = reportplayers($reportfile);
+my $players = $report->players;
my %resultdelta = qw(WIN 1 DISCONNECT 0 DRAW 0 LOSS -1);
for (@$players) {
defined $resultdelta{ $_->{result} }
my $place = $placetxt{$placeid} or die "Unknown place id: $placeid\n";
print "Resolved place '$placeid' to $place\n" if $DBG;
-use DBIx::Simple;
-my @dbinfo = do "dbinfo.inc.pl";
-my $Db = DBIx::Simple->connect(@dbinfo, {pg_enable_utf8 => 1})
+use Games::StarCraft::DB;
+my $Db = Games::StarCraft::DB->connect
or die "No database: $DBI::errstr\n";
$TEST and exit;
$Db->begin;
use Date::Parse;
-my ($start, $end) = map str2time($report->{$_}), qw(started ended);
+my ($start, $end) = map str2time($data->{$_}), qw(started ended);
use Date::Format;
$Db->insert("game", {
name => $name,
place => $place,
- map => $report->{mapfile},
- type => $report->{type},
+ map => $data->{mapfile},
+ type => $data->{type},
start => time2str('%Y-%m-%d %X', $start),
duration => sprintf('%d seconds', $end - $start),
})->rows or die "Game insert failed: ".$Db->error."\n";
-my $gameid = $Db->last_insert_id((undef) x 4, {sequence => "game_id_seq"});
+my $gameid = $Db->last_insert_id((undef) x 4, {sequence => "game_id_seq"})
+ or die "Couldn't find our game insertion: ".$Db->error."\n";
+print "Game inserted as # $gameid\n";
$Db->insert("play", {
game => $gameid,
--- /dev/null
+#!/usr/bin/env perl
+
+use strict;
+use warnings;
+
+use Net::IRC;
+
+my %botinfo = (
+ Nick => "schtarrbot",
+ Ircname => "schtarrbot",
+ Server => "shiar.net",
+ Port => 6667,
+);
+my @chaninfo = ("#schtarr");
+my %loginfo = (
+ filename => "/var/log/pvpgn/bnetd.log",
+ debug => 1,
+);
+
+my $irc = new Net::IRC;
+my $conn = $irc->newconn(%botinfo) or die "couldn't connect to server";
+my $joined = 0;
+
+$conn->add_global_handler('join', sub {
+ $joined = 1;
+});
+
+$conn->add_global_handler('376', sub {
+ # connect
+ $_[0]->join(@chaninfo) or die "couldn't connect to channel";
+});
+
+$conn->add_global_handler('public', sub {
+ my ($self, $event) = @_;
+ $event->args =~ m/^!(\w+)/ or next;
+ handle_cmd($1);
+});
+
+open my $log, "<", $loginfo{filename} or die $!;
+seek $log, 0, 2; # eof
+
+sub handle_cmd {
+}
+
+sub handle_log {
+ my ($func, $msg) = @_;
+
+ if ($func eq "_client_loginreq2" and $line =~ m{
+ "([^"]+)" \Q logged in (correct password)\E $
+ }x) {
+ my $nick = $1;
+ print "* login $nick\n";
+ $conn->privmsg($chaninfo[0], "$nick entered bnet");
+ }
+
+ elsif ($func eq "conn_destroy" and $line =~ m{
+ "([^"]+)" \Q logged out\E $
+ }x) {
+ my $nick = $1;
+ print "* logout $nick\n";
+ $conn->privmsg($chaninfo[0], "$nick left bnet");
+ }
+
+ elsif ($func eq "game_create" and $line =~ m{
+ \Qgame "\E ([^"]*) \Q" (pass "\E([^"]*)\Q") type \E(\d*)\(([^)]*)\)\Q startver \E(\d+)\Q created\E $
+ }x) {
+ my ($name, $pass, $typeid, $type, $version) = ($1, $2, $3, $4, $5);
+ print "* game created\n";
+ $conn->privmsg($chaninfo[0], "$type game '$name' created");
+ }
+
+ elsif ($func eq "_client_startgame4" and $line =~ m{
+ \Qgot startgame4 status for game "\E([^"]*)\Q" is 0x\E
+ }) {
+ my $game = $1;
+ print "* game started\n";
+ $conn->privmsg($chaninfo[0], "game '$game' started");
+ }
+
+ if ($func eq "game_report" and $line =~ m{
+ \Qgame report saved as "\E([^"]*)" $
+ }) {
+ my $report = $1;
+ print "* game reported\n";
+ }
+
+ elsif (not $loginfo{debug} and $func eq "game_destroy" and $line =~ m{
+ \Qgame deleted\E $
+ }x) {
+ print "* game deleted\n";
+ $conn->privmsg($chaninfo[0], "game closed");
+ }
+}
+
+while (1) {
+ sleep 1.5;
+ $irc->do_one_loop();
+ $joined or next;
+
+ seek $log, 0, 1; # clear eof condition
+ while (defined (my $line = readline $log)) {
+ my ($date, $level, $func, $msg) = $line =~ m{
+ ^ (\S+\s\S+\s\S+) \s \[([^\]\s]+)\s*\] \s ([^\s:]+): \s (.*) $
+ }x or warn("Invalid line: $line"), next;
+ $msg =~ s/(?:\[\d+\])+\s//g;
+# print ". $func ($msg)\n";
+ handle_log($func, $msg);
+ }
+}
+
use strict;
use warnings;
use Data::Dumper;
-
use Data::StarCraft::Replay;
+our $VERSION = '1.01';
+
my $SHOWWARN = 0;
my $ACTGIF = undef;
my $APMSVG = undef;
+my $DBNAME = undef;
+my $DBGAME = undef;
-use Getopt::Long;
+use Getopt::Long qw(:config bundling auto_version auto_help);
GetOptions(
"verbose|v!" => \$SHOWWARN,
"apm|a=s" => \$APMSVG,
"act" => \$ACTGIF,
+ "dbname|D=s" => \$DBNAME,
+ "dbid|d=s" => \$DBGAME,
);
use constant { APM_FIRSTFRAME => 80 / .042 };
my $number = shift @playdata;
defined $player[$number] and warn "Player #$number redefined";
my ($data) = unpackhash("VcccZ25", shift @playdata, qw(
- slot type race unknown name
+ slot type race team name
));
defined $race[$_] ? ($data->{race} = $race[$_]) :
warn "Unknown race #$_ for player $number"
}
for my $player (sort keys %stats) {
+ $stats{$player}{$_} = $player[$slot[$player]]{$_}
+ for keys %{ $player[$slot[$player]] };
my $row = $stats{$player};
$row->{last} ||= $map->[-1][0];
# printf("%-16s%6d actions (%3d micro,%4d macro);%4d APM\n",
my $name = showplayer($player);
- printf("%-16s%6d actions in%7d frames (%s) = %d APM\n",
+ printf("%d %-16s%6d actions in%7d frames (%s) = %d APM\n",
+ $row->{slot},
$name, $row->{actions}, $row->{last},
showtime($row->{last}),
# $row->{micro} / $row->{last} * 60 / .042 * 1.05,
select STDOUT;
}
+use Games::StarCraft::DB;
+my $Db = Games::StarCraft::DB->connect({RaiseError => 1})
+ or die "No database: $DBI::errstr\n";
+sub findaccount ($) {
+ my ($name) = @_;
+ my $query = $Db->query(q{
+ SELECT DISTINCT account FROM play
+ WHERE name = ? AND account IS NOT NULL
+ }, $name);
+ return $query->rows == 1 ? $query->list : undef;
+}
+
+if ($DBGAME) {{
+ print "\n";
+ my $game = $Db->query("SELECT * FROM game WHERE id=?", $DBGAME)->hash;
+ if (not $game) {
+ printf "Database game # %d not found\n", $DBGAME;
+ last;
+ }
+ if ($game->{map} ne $head->{map}) {
+ printf "Replay map (%s) does not match database map (%s)\n",
+ $head->{map}, $game->{map};
+ last;
+ }
+
+ $Db->begin;
+ $Db->insert("game", {
+ frames => $head->{frames},
+# map => $head->{map},
+# start => time2str('%Y-%m-%d %X', $head->{time}),
+ # endreplay => time2str('%Y-%m-%d %X', $repstats[9]), # mtime
+# durationguess => \"endreplay - start",
+ });
+ $Db->update("play", {
+ name => $_->{name}, #TODO: --force
+ race => $_->{race}, # --force
+ apm => $_->{gameactions} / ($_->{last} - APM_FIRSTFRAME) * 60 / .042,
+ team => $_->{team},
+ color => $_->{color},
+ }, {
+ game => $DBGAME,
+ slot => $_->{slot},
+ }) for values %stats;
+ $Db->commit;
+}}
+
+if ($DBNAME) {
+ print "\n";
+ my @repstats = stat $DBNAME or die "no rep: $!\n";
+ my ($name) = $DBNAME =~ m{.*/([^.]+)};
+
+ my %placetxt = (
+ bn => "bnet",
+ gr => "groningen",
+ md => "mdhq",
+ );
+ my ($placeid) = $name =~ /.*([a-z]{2})/;
+ my $place = defined $placetxt{$placeid} ? $placetxt{$placeid} : undef;
+
+ my $winslot;
+ if (@ARGV == 1 and $ARGV[0] =~ /^\d$/) {
+ $winslot = $ARGV[0];
+ }
+
+ $Db->begin;
+ $Db->insert("game", {
+ name => $name,
+ frames => $head->{frames},
+ map => $head->{map},
+ start => time2str('%Y-%m-%d %X', $head->{time}),
+ endreplay => time2str('%Y-%m-%d %X', $repstats[9]), # mtime
+# durationguess => \"endreplay - start",
+ place => $place,
+ });
+ my $gameid = $Db->last_insert_id((undef)x4, {sequence => "game_id_seq"});
+ $Db->update("game", {durationguess => \"endreplay - start"}, {id => $gameid});
+ $Db->insert("play", {
+ game => $gameid,
+ slot => $_->{slot},
+ name => $_->{name},
+ race => $_->{race},
+ apm => $_->{gameactions} / ($_->{last} - APM_FIRSTFRAME) * 60 / .042,
+ team => $_->{team},
+ color => $_->{color},
+ account => findaccount($_->{name}),
+ result => defined $winslot ? $_->{slot} == $winslot ? 1 : -1 : 0,
+ }) for values %stats;
+ $Db->commit;
+}
+
if ($APMSVG) {
my @seq; # player => time (s) => actions
$seq[$_->[1]][$_->[0] * .042]++ for @$map;
print $apmfile $svg;
}
+__END__
+
+=head1 NAME
+
+screp - StarCraft replay parser
+
+=head1 SYNOPSIS
+
+screp [options] < [replay data]
+
+ Options:
+ --verbose
+ --apm
+ --act
+ --dbname
+ --dbid
+
+=head1 OPTIONS
+
+=head1 AUTHOR
+
+Mischa POSLAWSKY <perl@shiar.org>
+
+=head1 STUFF
+
git.shiar.nl / perl / schtarr.git / commitdiff