4 # Copyright (c) 1993 - 2002 Tim Riker
6 # This package is free software; you can redistribute it and/or
7 # modify it under the terms of the license found in the file
8 # named LICENSE that should have accompanied this file.
10 # THIS PACKAGE IS PROVIDED ``AS IS'' AND WITHOUT ANY EXPRESS OR
11 # IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED
12 # WARRANTIES OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE.
16 use Fcntl qw(F_GETFL F_SETFL O_NONBLOCK);
23 eval "use LWP::UserAgent";
31 &::status("BZFlag module requires Socket.");
32 return 'BZFlag module not active';
34 if ($message =~ /^bzfquery\s+([^:]*)(?::([0-9]*))?$/xi) {
35 $retval = &query($1,$2);
36 } elsif ($message =~ /^bzflist$/xi) {
39 $retval = "BZFlag: unhandled command \"$message\"";
41 &::performStrictReply($retval);
46 my $ua = new LWP::UserAgent;
47 $ua->proxy('http', $::param{'httpProxy'}) if (&::IsParam("httpProxy"));
51 my $req = HTTP::Request->new('GET', 'http://db.bzflag.org/db/?action=LIST');
52 my $res = $ua->request($req);
55 for my $line (split("\n",$res->content)) {
56 my ($serverport, $version, $flags, $ip, $comments) = split(" ",$line,5);
57 # not "(A4)18" to handle old dumb perl
58 my ($style, $maxShots, $shakeWins, $shakeTimeout, $maxPlayerScore, $maxTeamScore, $maxTime,
59 $maxPlayers, $rogueSize, $rogueMax, $redSize, $redMax, $greenSize, $greenMax,
60 $blueSize, $blueMax, $purpleSize, $purpleMax, $observerSize, $observerMax) =
61 unpack("A4A4A4A4A4A4A4A2A2A2A2A2A2A2A2A2A2A2A2A2", $flags);
62 my $playerSize = hex($rogueSize) + hex($redSize) + hex($greenSize)
63 + hex($blueSize) + hex($purpleSize) + hex($observerSize);
64 $servers{$serverport} = $playerSize;
65 $servers{$version} += $playerSize;
66 $servers{'PLAYERS'} += $playerSize;
69 $response .= "s=$totalServers";
70 foreach my $key (sort {$servers{$b} <=> $servers{$a}} (keys(%servers))) {
71 if ($servers{$key} > 0) {
72 $response .= " $key($servers{$key})";
75 &::performStrictReply($response);
81 my $ua = new LWP::UserAgent;
82 $ua->proxy('http', $::param{'httpProxy'}) if (&::IsParam("httpProxy"));
86 my $req = HTTP::Request->new('GET', 'http://list.bzflag.org:5156/');
87 my $res = $ua->request($req);
91 for my $line (split("\n",$res->content)) {
92 my ($serverport, $version, $flags, $ip, $comments) = split(" ",$line,5);
93 # not "(A4)18" to handle old dumb perl
94 my ($style,$maxPlayers,$maxShots,
95 $rogueSize,$redSize,$greenSize,$blueSize,$purpleSize,
96 $rogueMax,$redMax,$greenMax,$blueMax,$purpleMax,
97 $shakeWins,$shakeTimeout,
98 $maxPlayerScore,$maxTeamScore,$maxTime) =
99 unpack("A4A4A4A4A4A4A4A4A4A4A4A4A4A4A4A4A4A4", $flags);
100 my $playerSize = hex($rogueSize) + hex($redSize) + hex($greenSize)
101 + hex($blueSize) + hex($purpleSize);
102 $servers{$serverport} = $playerSize;
104 $totalPlayers += $playerSize;
106 $response .= "s=$totalServers p=$totalPlayers";
107 foreach my $key (sort {$servers{$b} <=> $servers{$a}} (keys(%servers))) {
108 if ($servers{$key} > 0) {
109 $response .= " $key($servers{$key})";
112 &::performStrictReply($response);
117 my ($servernameport) = @_;
118 my ($servername,$port) = split(":",$servernameport);
120 &::status("BZFlag module requires Socket.");
121 return 'BZFlag module not active';
123 #my @teamName = ("Rogue", "Red", "Green", "Blue", "Purple", "Observer", "Rabbit");
124 my @teamName = ("X", "R", "G", "B", "P", "O", "K");
125 my ($message, $server, $response);
126 $port = 5154 unless $port;
129 my $sockaddr = 'S n a4 x8';
131 # port to port number
132 my ($name,$aliases,$proto) = getprotobyname('tcp');
133 ($name,$aliases,$port) = getservbyname($port,'tcp') unless $port =~ /^\d+$/;
136 my ($type,$len,$serveraddr);
137 ($name,$aliases,$type,$len,$serveraddr) = gethostbyname($servername);
138 $server = pack($sockaddr, AF_INET, $port, $serveraddr);
141 # TODO wrap this with a 5 second alarm()
142 return 'socket() error' unless socket(S1, AF_INET, SOCK_STREAM, $proto);
143 return "could not connect to $servername:$port" unless connect(S1, $server);
146 select(S1); $| = 1; select(STDOUT);
150 return 'read error' unless read(S1, $buffer, 8) == 8;
153 my ($magic,$major,$minor,$something,$revision) = unpack("a4 a1 a1 a1 a1", $buffer);
154 my ($version) = $magic . $major . $minor . $something . $revision;
156 # quit if version isn't valid
157 return 'not a bzflag server' if ($magic ne "BZFS");
158 $response .= "$major$minor$something$revision ";
160 if ($version eq "BZFS0026") {
161 # 1.11.x handled here
162 return 'read error' unless read(S1, $buffer, 1) == 1;
163 my ($id) = unpack("C", $buffer);
164 return "rejected by server" if ($id == 255);
167 print S1 pack("n2", 0, 0x7167);
170 my $nbytes = read(S1, $buffer, 4);
171 my ($infolen, $infocode) = unpack("n2", $buffer);
172 if ($infocode == 0x6774) {
173 # read and ignore MsgGameTime from new servers
174 $nbytes = read(S1, $buffer, 8);
175 $nbytes = read(S1, $buffer, 4);
176 ($infolen, $infocode) = unpack("n2", $buffer);
178 $nbytes = read(S1, $buffer, 42);
180 return "Error: read $nbytes bytes, expecting 46: $^E\n";
183 my ($style,$maxPlayers,$maxShots,
184 $rogueSize,$redSize,$greenSize,$blueSize,$purpleSize,$observerSize,
185 $rogueMax,$redMax,$greenMax,$blueMax,$purpleMax,$observerMax,
186 $shakeWins,$shakeTimeout,
187 $maxPlayerScore,$maxTeamScore,$maxTime,$timeElapsed) = unpack("n23", $buffer);
188 return "bad server data $infocode" unless $infocode == 0x7167;
190 # send players request
191 print S1 pack("n2", 0, 0x7170);
193 # get number of teams and players we'll be receiving
194 return 'count read error' unless read(S1, $buffer, 8) == 8;
195 my ($countlen,$countcode,$numTeams,$numPlayers) = unpack("n4", $buffer);
198 return 'bad count data' unless $countcode == 0x7170;
199 return 'count read error' unless read(S1, $buffer, 5) == 5;
200 ($countlen,$countcode,$numTeams) = unpack("n n C", $buffer);
202 return 'team read error' unless read(S1, $buffer, 8) == 8;
203 my ($team,$size,$won,$lost) = unpack("n4", $buffer);
205 my $score = $won - $lost;
206 $response .= "$teamName[$team]:$score($won-$lost) ";
211 for (1..$numPlayers) {
212 last unless read(S1, $buffer, 175) == 175;
213 my ($playerlen,$playercode,$pID,$type,$team,$won,$lost,$tks,$sign,$email) =
214 unpack("n2Cn5A32A128", $buffer);
215 #my ($playerlen,$playercode,$pAddr,$pPort,$pNum,$type,$team,$won,$lost,$sign,$email) =
216 # unpack("n2Nn2 n4A32A128", $buffer);
217 return 'bad player data' unless $playercode == 0x6170;
218 my $score = $won - $lost;
219 $response .= " $sign($teamName[$team]";
220 $response .= ":$email" if ($email);
221 $response .= ")$score($won-$lost)";
223 $response .= "No Players" if ($numPlayers < 1);
226 } elsif ($major == 1 && $minor == 9) {
227 # 1.10.x handled here
228 $revision = $something * 10 + $revision;
229 return 'read error' unless read(S1, $buffer, 1) == 1;
230 my ($id) = unpack("C", $buffer);
233 print S1 pack("n2", 0, 0x7167);
235 # FIXME the packets are wrong from here down
237 return 'server read error' unless read(S1, $buffer, 40) == 40;
238 my ($infolen,$infocode,$style,$maxPlayers,$maxShots,
239 $rogueSize,$redSize,$greenSize,$blueSize,$purpleSize,
240 $rogueMax,$redMax,$greenMax,$blueMax,$purpleMax,
241 $shakeWins,$shakeTimeout,
242 $maxPlayerScore,$maxTeamScore,$maxTime) = unpack("n20", $buffer);
243 return 'bad server data' unless $infocode == 0x7167;
245 # send players request
246 print S1 pack("n2", 0, 0x7170);
248 # get number of teams and players we'll be receiving
249 return 'count read error' unless read(S1, $buffer, 8) == 8;
250 my ($countlen,$countcode,$numTeams,$numPlayers) = unpack("n4", $buffer);
253 return 'bad count data' unless $countcode == 0x7170;
254 return 'count read error' unless read(S1, $buffer, 5) == 5;
255 ($countlen,$countcode,$numTeams) = unpack("n n C", $buffer);
257 return 'team read error' unless read(S1, $buffer, 8) == 8;
258 my ($team,$size,$won,$lost) = unpack("n4", $buffer);
260 my $score = $won - $lost;
261 $response .= "$teamName[$team]:$score($won-$lost) ";
266 for (1..$numPlayers) {
267 last unless read(S1, $buffer, 175) == 175;
268 my ($playerlen,$playercode,$pID,$type,$team,$won,$lost,$tks,$sign,$email) =
269 unpack("n2Cn5A32A128", $buffer);
270 #my ($playerlen,$playercode,$pAddr,$pPort,$pNum,$type,$team,$won,$lost,$sign,$email) =
271 # unpack("n2Nn2 n4A32A128", $buffer);
272 return 'bad player data' unless $playercode == 0x6170;
273 my $score = $won - $lost;
274 $response .= " $sign($teamName[$team]";
275 $response .= ":$email" if ($email);
276 $response .= ")$score($won-$lost)";
278 $response .= "No Players" if ($numPlayers < 1);
282 } elsif ($major == 1 && $minor == 0 && $something == 7) {
283 # 1.7* versions handled here
284 # old servers send a reconnect port number
285 return 'read error' unless read(S1, $buffer, 2) == 2;
286 my ($reconnect) = unpack("n", $buffer);
287 $minor = $minor * 10 + $something;
289 return 'rejected by server' if ($reconnect == 0);
291 # reconnect on new port
292 $server = pack($sockaddr, AF_INET, $reconnect, $serveraddr);
293 return 'socket() error on reconnect' unless socket(S, AF_INET, SOCK_STREAM, $proto);
294 return "could not reconnect to $servername:$reconnect" unless connect(S, $server);
295 select(S); $| = 1; select(STDOUT);
301 print S pack("n2", 0, 0x7167);
304 return 'server read error' unless read(S, $buffer, 40) == 40;
305 my ($infolen,$infocode,$style,$maxPlayers,$maxShots,
306 $rogueSize,$redSize,$greenSize,$blueSize,$purpleSize,
307 $rogueMax,$redMax,$greenMax,$blueMax,$purpleMax,
308 $shakeWins,$shakeTimeout,
309 $maxPlayerScore,$maxTeamScore,$maxTime) = unpack("n20", $buffer);
310 return 'bad server data' unless $infocode == 0x7167;
312 # send players request
313 print S pack("n2", 0, 0x7170);
315 # get number of teams and players we'll be receiving
316 return 'count read error' unless read(S, $buffer, 8) == 8;
317 my ($countlen,$countcode,$numTeams,$numPlayers) = unpack("n4", $buffer);
318 return 'bad count data' unless $countcode == 0x7170;
322 return 'team read error' unless read(S, $buffer, 14) == 14;
323 my ($teamlen,$teamcode,$team,$size,$aSize,$won,$lost) = unpack("n7", $buffer);
324 return 'bad team data' unless $teamcode == 0x7475;
326 my $score = $won - $lost;
327 $response .= "$teamName[$team]:$score($won-$lost) ";
332 for (1..$numPlayers) {
333 last unless read(S, $buffer, 180) == 180;
334 my ($playerlen,$playercode,$pAddr,$pPort,$pNum,$type,$team,$won,$lost,$sign,$email) =
335 unpack("n2Nn2 n4A32A128", $buffer);
336 return 'bad player data' unless $playercode == 0x6170;
337 my $score = $won - $lost;
338 $response .= " $sign($teamName[$team]";
339 $response .= ":$email" if ($email);
340 $response .= ")$score($won-$lost)";
342 $response .= "No Players" if ($numPlayers <= 1);
347 $response = "incompatible version: $version";
354 my ($servernameport) = @_;
355 &::performStrictReply(&querytext($servernameport));