html output
[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 ($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 }