misc/tools/weapon-profiler.pl

   1 #!/usr/bin/perl
   2
   3 # no warranty for this script
   4 # and no documentation
   5 # take it or leave it
   6
   7 use strict;
   8 use warnings;
   9 use FindBin; use lib $FindBin::Bin;
  10 use IO::Socket;
  11 use Socket;
  12 use sigtrap qw(die normal-signals);
  13 use WeaponEncounterProfile;
  14
  15 my ($statsfile) = @ARGV;
  16 my $password = $ENV{rcon_password};
  17 my $server = $ENV{rcon_address};
  18 my $bind = $ENV{rcon_bindaddress};
  19
  20 my $stats;
  21
  22 sub AddKill($$$$$)
  23 {
  24         my ($addr, $map, $attackerweapon, $targweapon, $type) = @_;
  25         $stats->event($addr, $map, $attackerweapon, $targweapon, $type);
  26 }
  27
  28 sub StoreData()
  29 {
  30         $stats->save();
  31 }
  32
  33 sub LoadData()
  34 {
  35         $stats = WeaponEncounterProfile->new($statsfile);
  36 }
  37
  38 $SIG{ALRM} = sub
  39 {
  40         print STDERR "Operation timed out.\n";
  41         exit 1;
  42 };
  43
  44 our @discosockets = ();
  45 sub LogDestUDP($)
  46 {
  47         # connects to a DP server using rcon with log_dest_udp
  48         my ($sock) = @_;
  49         my $value = sprintf "%s:%d", $sock->sockhost(), $sock->sockport();
  50         $sock->send("\377\377\377\377rcon $password log_dest_udp", 0)
  51                 or die "send rcon: $!";
  52         alarm 15;
  53         for(;;)
  54         {
  55                 $sock->recv(my $response, 2048, 0)
  56                         or die "recv: $!";
  57                 if($response =~ /^\377\377\377\377n"log_dest_udp" is "(.*)" \[".*"\]\n$/s)
  58                 {
  59                         alarm 0;
  60                         my @dests = split /\s+/, $1;
  61                         return
  62                                 if grep { $_ eq $value } @dests;
  63                         push @dests, $value;
  64                         $sock->send("\377\377\377\377rcon $password log_dest_udp \"@dests\"");
  65                         last;
  66                 }
  67         }
  68         alarm 0;
  69         push @discosockets, [$sock, $value];
  70
  71         END
  72         {
  73                 for(@discosockets)
  74                 {
  75                         my ($s, $v) = @$_;
  76                         # disconnects (makes the server stop send the data to us)
  77                         $s->send("\377\377\377\377rcon $password log_dest_udp", 0)
  78                                 or die "send rcon: $!";
  79                         alarm 15;
  80                         for(;;)
  81                         {
  82                                 $s->recv(my $response, 2048, 0)
  83                                         or die "recv: $!";
  84                                 if($response =~ /^\377\377\377\377n"log_dest_udp" is "(.*)" \[".*"\]\n$/s)
  85                                 {
  86                                         alarm 0;
  87                                         my @dests = split /\s+/, $1;
  88                                         return
  89                                                 if not grep { $_ eq $v } @dests;
  90                                         @dests = grep { $_ ne $v } @dests;
  91                                         $s->send("\377\377\377\377rcon $password log_dest_udp \"@dests\"");
  92                                         last;
  93                                 }
  94                         }
  95                         alarm 0;
  96                 }
  97         }
  98 }
  99
 100 sub sockaddr_readable($)
 101 {
 102         my ($binary) = @_;
 103         my ($port, $addr) = sockaddr_in $binary;
 104         return sprintf "%s:%d", inet_ntoa($addr), $port;
 105 }
 106
 107 my $sock;
 108 if(defined $bind)
 109 {
 110         # bind to a port and wait for any packets
 111         $sock = IO::Socket::INET->new(Proto => 'udp', LocalAddr => $bind, LocalPort => 26000)
 112                 or die "socket: $!";
 113 }
 114 else
 115 {
 116         # connect to a DP server
 117         $sock = IO::Socket::INET->new(Proto => 'udp', PeerAddr => $server, PeerPort => 26000)
 118                 or die "socket: $!";
 119         LogDestUDP $sock;
 120 }
 121 my %currentmap = ();
 122
 123 my %bots = ();
 124
 125 LoadData();
 126 while(my $addr = sockaddr_readable $sock->recv($_, 2048, 0))
 127 {
 128         $addr = $server
 129                 if not defined $bind;
 130         s/^\377\377\377\377n//
 131                 or next;
 132         for(split /\r?\n/, $_)
 133         {
 134                 if(/^:gamestart:([^:]+):/)
 135                 {
 136                         StoreData();
 137                         $currentmap{$addr} = $1;
 138                         $bots{$addr} = {};
 139                         print "($addr) switching to $1\n";
 140                         next;
 141                 }
 142
 143                 next
 144                         unless defined $currentmap{$addr};
 145                 if(/^:join:(\d+):bot:/)
 146                 {
 147                         $bots{$addr}{$1} = 1;
 148                 }
 149                 elsif(/^:kill:frag:(\d+):(\d+):type=(\d+):items=(\d+)([A-Z]*)(?:|(\d+)):victimitems=(\d+)([A-Z]*)(?:|(\d+))$/)
 150                 {
 151                         my ($a, $b, $type, $killweapon, $killflags, $killrunes, $victimweapon, $victimflags, $victimrules) = ($1, $2, $3, $4, $5, $6, $7, $8, $9);
 152                         next
 153                                 if exists $bots{$addr}{$a} or exists $bots{$addr}{$b}; # only count REAL kills
 154                         $type &= 0xFF
 155                                 if $type < 10000;
 156                         $killweapon = $type
 157                                 if $stats->weaponid_valid($type); # if $type is not a weapon deathtype, count the weapon of the killer
 158                         $killweapon = 0
 159                                 if not $stats->weaponid_valid($killweapon); # invalid weapon? that's 0 then
 160                         $victimweapon = 0
 161                                 if not $stats->weaponid_valid($victimweapon); # dito
 162                         next
 163                                 if $killflags =~ /S|I/ or $victimflags =~ /T/; # no strength, shield or typekills (these skew the statistics)
 164                         AddKill($addr, $currentmap{$addr}, $killweapon, $victimweapon, +1);
 165                 }
 166                 elsif(/^:kill:suicide:\d+:\d+:type=(\d+):items=(\d+)([A-Z]*)(?:|(\d+))$/)
 167                 {
 168                         my ($type, $killweapon, $killflags, $killrunes) = ($1, $2, $3, $4, $5, $6, $7);
 169                         $type &= 0xFF
 170                                 if $type < 10000;
 171                         $killweapon = $type
 172                                 if $stats->weaponid_valid($type);
 173                         $killweapon = 0
 174                                 if not $stats->weaponid_valid($killweapon);
 175                         next
 176                                 if $killflags =~ /S/; # no strength suicides (happen too easily accidentally)
 177                         AddKill($addr, $currentmap{$addr}, $killweapon, $killweapon, +1);
 178                 }
 179         }
 180 }