weapon profiler
[divverent/nexuiz.git] / 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 }