From: Shiar Date: Sat, 19 Jan 2008 05:29:47 +0000 (+0100) Subject: Merge commit 'raz/master' X-Git-Url: http://git.shiar.net/perl/schtarr.git/commitdiff_plain/65b175df2569427fb67295c5e131c94668fecbf6?hp=d6d562d921c72ddc11597a2c45fdc5182d5907cf Merge commit 'raz/master' Conflicts: screp --- diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..79842f4 --- /dev/null +++ b/.gitignore @@ -0,0 +1 @@ +/Games/StarCraft/DB/Local.pm diff --git a/Data/StarCraft/PvPGN/Report.pm b/Data/StarCraft/PvPGN/Report.pm new file mode 100644 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{([^<]+)} or next; + while (1) { + defined $player[++$i] + or die("More entries than $i found players\n"); + last unless $player[$i]->{result} eq "DISCONNECT"; + } + $player[$i]->{race}= $1; + } + + return \@player; +} + +1; + diff --git a/Games/StarCraft/DB.pm b/Games/StarCraft/DB.pm new file mode 100644 index 0000000..11b645e --- /dev/null +++ b/Games/StarCraft/DB.pm @@ -0,0 +1,25 @@ +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; + diff --git a/new b/new new file mode 100755 index 0000000..5490d07 --- /dev/null +++ b/new @@ -0,0 +1,81 @@ +#!/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')); + diff --git a/pvpgnreport b/pvpgnreport index 1a91ddf..1f1abea 100755 --- a/pvpgnreport +++ b/pvpgnreport @@ -2,61 +2,28 @@ 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{([^<]+)} or next; - while (1) { - defined $player[++$i] - or die("More 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} } @@ -74,9 +41,8 @@ my ($placeid) = $name =~ /.*([a-z]{2})/; 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; @@ -84,17 +50,19 @@ $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, diff --git a/schtarrbot b/schtarrbot new file mode 100755 index 0000000..b83adcf --- /dev/null +++ b/schtarrbot @@ -0,0 +1,110 @@ +#!/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); + } +} + diff --git a/screp b/screp index a97ea97..dc24f05 100755 --- a/screp +++ b/screp @@ -2,18 +2,23 @@ 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 }; @@ -59,7 +64,7 @@ for (0 .. 11) { 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" @@ -120,11 +125,14 @@ for (@$map) { } 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, @@ -208,6 +216,96 @@ if ($ACTGIF) { 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; @@ -264,3 +362,28 @@ if ($APMSVG) { 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 + +=head1 STUFF +