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