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.
22 eval "use LWP::UserAgent";
30 &main::status("BZFlag module requires Socket.");
31 return 'BZFlag module not active';
33 if ($message =~ /^bzfquery\s+([^:]*)(?::([0-9]*))?$/xi) {
34 $retval = &query($1,$2);
35 } elsif ($message =~ /^bzflist$/xi) {
38 $retval = "BZFlag: unhandled command \"$message\"";
40 &::performStrictReply($retval);
45 my $ua = new LWP::UserAgent;
46 $ua->proxy('http', $::param{'httpProxy'}) if (&::IsParam("httpProxy"));
50 my $req = HTTP::Request->new('GET', 'http://list.bzflag.org:5156/');
51 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,$maxPlayers,$maxShots,
59 $rogueSize,$redSize,$greenSize,$blueSize,$purpleSize,
60 $rogueMax,$redMax,$greenMax,$blueMax,$purpleMax,
61 $shakeWins,$shakeTimeout,
62 $maxPlayerScore,$maxTeamScore,$maxTime) =
63 unpack("A4A4A4A4A4A4A4A4A4A4A4A4A4A4A4A4A4A4", $flags);
64 my $playerSize = hex($rogueSize) + hex($redSize) + hex($greenSize)
65 + hex($blueSize) + hex($purpleSize);
66 $servers{$serverport} = $playerSize;
68 $totalPlayers += $playerSize;
70 $response .= "s=$totalServers p=$totalPlayers";
71 foreach my $key (sort {$servers{$b} <=> $servers{$a}} (keys(%servers))) {
72 if ($servers{$key} > 0) {
73 $response .= " $key($servers{$key})";
76 &::performStrictReply($response);
80 sub BZFlag::querytext {
81 my ($servernameport) = @_;
82 my ($servername,$port) = split(":",$servernameport);
84 &main::status("BZFlag module requires Socket.");
85 return 'BZFlag module not active';
87 #my @teamName = ("Rogue", "Red", "Green", "Blue", "Purple");
88 my @teamName = ("X", "R", "G", "B", "P");
89 my ($message, $server, $response);
90 $port = 5155 unless $port;
93 my $sockaddr = 'S n a4 x8';
96 my ($name,$aliases,$proto) = getprotobyname('tcp');
97 ($name,$aliases,$port) = getservbyname($port,'tcp') unless $port =~ /^\d+$/;
100 my ($type,$len,$serveraddr);
101 ($name,$aliases,$type,$len,$serveraddr) = gethostbyname($servername);
102 $server = pack($sockaddr, AF_INET, $port, $serveraddr);
105 return 'socket() error' unless socket(S1, AF_INET, SOCK_STREAM, $proto);
106 return "could not connect to $servername:$port" unless connect(S1, $server);
109 select(S1); $| = 1; select(STDOUT);
113 return 'read error' unless read(S1, $buffer, 10) == 10;
116 my ($magic,$major,$minor,$revision);
117 ($magic,$major,$minor,$revision,$port) = unpack("a4 a1 a2 a1 n", $buffer);
119 # quit if version isn't valid
120 return 'not a bzflag server' if ($magic ne "BZFS");
121 # try incompatible for BZFlag:Zero etc.
122 $response = 'incompatible version: ' if ($major < 1);
123 $response = 'incompatible version: ' if ($major == 1 && $minor < 7);
124 $response = 'incompatible version: ' if ($major == 1 && $minor == 7 && $revision eq "b");
127 return 'rejected by server' if ($port == 0);
129 # reconnect on new port
130 $server = pack($sockaddr, AF_INET, $port, $serveraddr);
131 return 'socket() error on reconnect' unless socket(S, AF_INET, SOCK_STREAM, $proto);
132 return "could not reconnect to $servername:$port" unless connect(S, $server);
133 select(S); $| = 1; select(STDOUT);
139 print S pack("n2", 0, 0x7167);
142 return 'server read error' unless read(S, $buffer, 40) == 40;
143 my ($infolen,$infocode,$style,$maxPlayers,$maxShots,
144 $rogueSize,$redSize,$greenSize,$blueSize,$purpleSize,
145 $rogueMax,$redMax,$greenMax,$blueMax,$purpleMax,
146 $shakeWins,$shakeTimeout,
147 $maxPlayerScore,$maxTeamScore,$maxTime) = unpack("n20", $buffer);
148 return 'bad server data' unless $infocode == 0x7167;
150 # send players request
151 print S pack("n2", 0, 0x7170);
153 # get number of teams and players we'll be receiving
154 return 'count read error' unless read(S, $buffer, 8) == 8;
155 my ($countlen,$countcode,$numTeams,$numPlayers) = unpack("n4", $buffer);
156 return 'bad count data' unless $countcode == 0x7170;
160 return 'team read error' unless read(S, $buffer, 14) == 14;
161 my ($teamlen,$teamcode,$team,$size,$aSize,$won,$lost) = unpack("n7", $buffer);
162 return 'bad team data' unless $teamcode == 0x7475;
164 my $score = $won - $lost;
165 $response .= "$teamName[$team]:$score($won-$lost) ";
170 for (1..$numPlayers) {
171 last unless read(S, $buffer, 180) == 180;
172 my ($playerlen,$playercode,$pAddr,$pPort,$pNum,$type,$team,$won,$lost,$sign,$email) =
173 unpack("n2Nn2 n4A32A128", $buffer);
174 return 'bad player data' unless $playercode == 0x6170;
175 my $score = $won - $lost;
176 $response .= " $sign($teamName[$team]";
177 $response .= ":$email" if ($email);
178 $response .= ")$score($won-$lost)";
180 $response .= "No Players" if ($numPlayers <= 1);
189 my ($servernameport) = @_;
190 &::performStrictReply(&querytext($servernameport));