X-Git-Url: https://git.donarmstrong.com/?a=blobdiff_plain;f=src%2FModules%2FBZFlag.pl;h=69672c2793b4ae73bd2d507a175527e3499e7cd8;hb=e1808cadf169b3811d694a4aa3d2a03ec2eeae84;hp=82e94b1f5d3cbdd60be812c1639c394d10d934d0;hpb=d6e1cc3fe59250922a5c84398fefdd22f911f8bf;p=infobot.git diff --git a/src/Modules/BZFlag.pl b/src/Modules/BZFlag.pl index 82e94b1..69672c2 100755 --- a/src/Modules/BZFlag.pl +++ b/src/Modules/BZFlag.pl @@ -24,70 +24,70 @@ BEGIN { $no_BZFlag++ if ($@); } -sub BZFlag::BZFlag { +sub BZFlag { my ($message) = @_; - my ($retval); + my ($retval); if ($no_BZFlag) { - &main::status("BZFlag module requires Socket."); + &::status("BZFlag module requires Socket."); return 'BZFlag module not active'; } if ($message =~ /^bzfquery\s+([^:]*)(?::([0-9]*))?$/xi) { $retval = &query($1,$2); } elsif ($message =~ /^bzflist$/xi) { $retval = &list(); - } else { + } else { $retval = "BZFlag: unhandled command \"$message\""; } &::performStrictReply($retval); } -sub BZFlag::list { +sub list { my ($response); my $ua = new LWP::UserAgent; - $ua->proxy('http', $::param{'httpProxy'}) if (&::IsParam("httpProxy")); + $ua->proxy('http', $::param{'httpProxy'}) if (&::IsParam('httpProxy')); $ua->timeout(5); my $req = HTTP::Request->new('GET', 'http://db.bzflag.org/db/?action=LIST'); my $res = $ua->request($req); - my %servers; - my $totalServers = 0; - my $totalPlayers = 0; + my %servers; + my $totalServers = 0; for my $line (split("\n",$res->content)) { my ($serverport, $version, $flags, $ip, $comments) = split(" ",$line,5); # not "(A4)18" to handle old dumb perl my ($style, $maxShots, $shakeWins, $shakeTimeout, $maxPlayerScore, $maxTeamScore, $maxTime, $maxPlayers, $rogueSize, $rogueMax, $redSize, $redMax, $greenSize, $greenMax, $blueSize, $blueMax, $purpleSize, $purpleMax, $observerSize, $observerMax) = - unpack("A4A4A4A4A4A4A4A2A2A2A2A2A2A2A2A2A2A2A2A2", $flags); + unpack('A4A4A4A4A4A4A4A2A2A2A2A2A2A2A2A2A2A2A2A2', $flags); my $playerSize = hex($rogueSize) + hex($redSize) + hex($greenSize) + hex($blueSize) + hex($purpleSize) + hex($observerSize); - $servers{$serverport} = $playerSize; - $totalServers += 1; - $totalPlayers += $playerSize; + $servers{$serverport} = $playerSize; + $servers{$version} += $playerSize; + $servers{'PLAYERS'} += $playerSize; + $totalServers += 1; } - $response .= "s=$totalServers p=$totalPlayers"; - foreach my $key (sort {$servers{$b} <=> $servers{$a}} (keys(%servers))) { + $response .= "s=$totalServers"; + foreach my $key (sort {$servers{$b} <=> $servers{$a}} (keys(%servers))) { if ($servers{$key} > 0) { $response .= " $key($servers{$key})"; } - } + } &::performStrictReply($response); return; } -sub BZFlag::list17 { +sub list17 { my ($response); my $ua = new LWP::UserAgent; - $ua->proxy('http', $::param{'httpProxy'}) if (&::IsParam("httpProxy")); + $ua->proxy('http', $::param{'httpProxy'}) if (&::IsParam('httpProxy')); $ua->timeout(5); my $req = HTTP::Request->new('GET', 'http://list.bzflag.org:5156/'); my $res = $ua->request($req); - my %servers; - my $totalServers = 0; - my $totalPlayers = 0; + my %servers; + my $totalServers = 0; + my $totalPlayers = 0; for my $line (split("\n",$res->content)) { my ($serverport, $version, $flags, $ip, $comments) = split(" ",$line,5); # not "(A4)18" to handle old dumb perl @@ -96,32 +96,32 @@ sub BZFlag::list17 { $rogueMax,$redMax,$greenMax,$blueMax,$purpleMax, $shakeWins,$shakeTimeout, $maxPlayerScore,$maxTeamScore,$maxTime) = - unpack("A4A4A4A4A4A4A4A4A4A4A4A4A4A4A4A4A4A4", $flags); + unpack('A4A4A4A4A4A4A4A4A4A4A4A4A4A4A4A4A4A4', $flags); my $playerSize = hex($rogueSize) + hex($redSize) + hex($greenSize) + hex($blueSize) + hex($purpleSize); - $servers{$serverport} = $playerSize; - $totalServers += 1; - $totalPlayers += $playerSize; + $servers{$serverport} = $playerSize; + $totalServers += 1; + $totalPlayers += $playerSize; } - $response .= "s=$totalServers p=$totalPlayers"; - foreach my $key (sort {$servers{$b} <=> $servers{$a}} (keys(%servers))) { + $response .= "s=$totalServers p=$totalPlayers"; + foreach my $key (sort {$servers{$b} <=> $servers{$a}} (keys(%servers))) { if ($servers{$key} > 0) { $response .= " $key($servers{$key})"; } - } + } &::performStrictReply($response); return; } -sub BZFlag::querytext { +sub querytext { my ($servernameport) = @_; my ($servername,$port) = split(":",$servernameport); if ($no_BZFlag) { - &main::status("BZFlag module requires Socket."); + &::status("BZFlag module requires Socket."); return 'BZFlag module not active'; } - #my @teamName = ("Rogue", "Red", "Green", "Blue", "Purple"); - my @teamName = ("X", "R", "G", "B", "P"); + #my @teamName = ('Rogue', 'Red', 'Green', 'Blue', 'Purple', 'Observer', 'Rabbit'); + my @teamName = ('X', 'R', 'G', 'B', 'P', 'O', 'K'); my ($message, $server, $response); $port = 5154 unless $port; @@ -130,7 +130,7 @@ sub BZFlag::querytext { # port to port number my ($name,$aliases,$proto) = getprotobyname('tcp'); - ($name,$aliases,$port) = getservbyname($port,'tcp') unless $port =~ /^\d+$/; + ($name,$aliases,$port) = getservbyname($port,'tcp') unless $port =~ /^\d+$/; # get server address my ($type,$len,$serveraddr); @@ -138,6 +138,7 @@ sub BZFlag::querytext { $server = pack($sockaddr, AF_INET, $port, $serveraddr); # connect + # TODO wrap this with a 5 second alarm() return 'socket() error' unless socket(S1, AF_INET, SOCK_STREAM, $proto); return "could not connect to $servername:$port" unless connect(S1, $server); @@ -150,16 +151,86 @@ sub BZFlag::querytext { # parse reply my ($magic,$major,$minor,$something,$revision) = unpack("a4 a1 a1 a1 a1", $buffer); + my ($version) = $magic . $major . $minor . $something . $revision; # quit if version isn't valid - return 'not a bzflag server' if ($magic ne "BZFS"); - # check version - if ($major == 1 && $minor == 9) { - $revision = $something * 10 + $revision; - $response = "version: $magic $major $minor $revision"; + return 'not a bzflag server' if ($magic ne 'BZFS'); + $response .= "$major$minor$something$revision "; + # check version + if ($version eq 'BZFS0026') { + # 1.11.x handled here + return 'read error' unless read(S1, $buffer, 1) == 1; + my ($id) = unpack('C', $buffer); + return "rejected by server" if ($id == 255); # send game request - print S1 pack("n2", 0, 0x7167); + print S1 pack('n2', 0, 0x7167); + + # get reply + my $nbytes = read(S1, $buffer, 4); + my ($infolen, $infocode) = unpack('n2', $buffer); + if ($infocode == 0x6774) { + # read and ignore MsgGameTime from new servers + $nbytes = read(S1, $buffer, 8); + $nbytes = read(S1, $buffer, 4); + ($infolen, $infocode) = unpack('n2', $buffer); + } + $nbytes = read(S1, $buffer, 42); + if ($nbytes != 42) { + return "Error: read $nbytes bytes, expecting 46: $^E\n"; + } + + my ($style,$maxPlayers,$maxShots, + $rogueSize,$redSize,$greenSize,$blueSize,$purpleSize,$observerSize, + $rogueMax,$redMax,$greenMax,$blueMax,$purpleMax,$observerMax, + $shakeWins,$shakeTimeout, + $maxPlayerScore,$maxTeamScore,$maxTime,$timeElapsed) = unpack('n23', $buffer); + return "bad server data $infocode" unless $infocode == 0x7167; + + # send players request + print S1 pack('n2', 0, 0x7170); + + # get number of teams and players we'll be receiving + return 'count read error' unless read(S1, $buffer, 8) == 8; + my ($countlen,$countcode,$numTeams,$numPlayers) = unpack('n4', $buffer); + + # get the teams + return 'bad count data' unless $countcode == 0x7170; + return 'count read error' unless read(S1, $buffer, 5) == 5; + ($countlen,$countcode,$numTeams) = unpack("n n C", $buffer); + for (1..$numTeams) { + return 'team read error' unless read(S1, $buffer, 8) == 8; + my ($team,$size,$won,$lost) = unpack('n4', $buffer); + if ($size > 0) { + my $score = $won - $lost; + $response .= "$teamName[$team]:$score($won-$lost) "; + } + } + + # get the players + for (1..$numPlayers) { + last unless read(S1, $buffer, 175) == 175; + my ($playerlen,$playercode,$pID,$type,$team,$won,$lost,$tks,$sign,$email) = + unpack('n2Cn5A32A128', $buffer); + #my ($playerlen,$playercode,$pAddr,$pPort,$pNum,$type,$team,$won,$lost,$sign,$email) = + # unpack("n2Nn2 n4A32A128", $buffer); + return 'bad player data' unless $playercode == 0x6170; + my $score = $won - $lost; + $response .= " $sign($teamName[$team]"; + $response .= ":$email" if ($email); + $response .= ")$score($won-$lost)"; + } + $response .= "No Players" if ($numPlayers < 1); + + # close socket + } elsif ($major == 1 && $minor == 9) { + # 1.10.x handled here + $revision = $something * 10 + $revision; + return 'read error' unless read(S1, $buffer, 1) == 1; + my ($id) = unpack('C', $buffer); + + # send game request + print S1 pack('n2', 0, 0x7167); # FIXME the packets are wrong from here down # get reply @@ -168,22 +239,23 @@ sub BZFlag::querytext { $rogueSize,$redSize,$greenSize,$blueSize,$purpleSize, $rogueMax,$redMax,$greenMax,$blueMax,$purpleMax, $shakeWins,$shakeTimeout, - $maxPlayerScore,$maxTeamScore,$maxTime) = unpack("n20", $buffer); + $maxPlayerScore,$maxTeamScore,$maxTime) = unpack('n20', $buffer); return 'bad server data' unless $infocode == 0x7167; # send players request - print S1 pack("n2", 0, 0x7170); + print S1 pack('n2', 0, 0x7170); # get number of teams and players we'll be receiving return 'count read error' unless read(S1, $buffer, 8) == 8; - my ($countlen,$countcode,$numTeams,$numPlayers) = unpack("n4", $buffer); - return 'bad count data' unless $countcode == 0x7170; + my ($countlen,$countcode,$numTeams,$numPlayers) = unpack('n4', $buffer); # get the teams + return 'bad count data' unless $countcode == 0x7170; + return 'count read error' unless read(S1, $buffer, 5) == 5; + ($countlen,$countcode,$numTeams) = unpack("n n C", $buffer); for (1..$numTeams) { - return 'team read error' unless read(S1, $buffer, 14) == 14; - my ($teamlen,$teamcode,$team,$size,$aSize,$won,$lost) = unpack("n7", $buffer); - return 'bad team data' unless $teamcode == 0x7475; + return 'team read error' unless read(S1, $buffer, 8) == 8; + my ($team,$size,$won,$lost) = unpack('n4', $buffer); if ($size > 0) { my $score = $won - $lost; $response .= "$teamName[$team]:$score($won-$lost) "; @@ -192,24 +264,27 @@ sub BZFlag::querytext { # get the players for (1..$numPlayers) { - last unless read(S1, $buffer, 180) == 180; - my ($playerlen,$playercode,$pAddr,$pPort,$pNum,$type,$team,$won,$lost,$sign,$email) = - unpack("n2Nn2 n4A32A128", $buffer); + last unless read(S1, $buffer, 175) == 175; + my ($playerlen,$playercode,$pID,$type,$team,$won,$lost,$tks,$sign,$email) = + unpack('n2Cn5A32A128', $buffer); + #my ($playerlen,$playercode,$pAddr,$pPort,$pNum,$type,$team,$won,$lost,$sign,$email) = + # unpack("n2Nn2 n4A32A128", $buffer); return 'bad player data' unless $playercode == 0x6170; my $score = $won - $lost; $response .= " $sign($teamName[$team]"; $response .= ":$email" if ($email); $response .= ")$score($won-$lost)"; } - $response .= "No Players" if ($numPlayers <= 1); + $response .= "No Players" if ($numPlayers < 1); # close socket close(S1); } elsif ($major == 1 && $minor == 0 && $something == 7) { - # old servers send a reconnect port number - return 'read error' unless read(S1, $buffer, 2) == 2; - my ($reconnect) = unpack("n", $buffer); - $minor = $minor * 10 + $something; + # 1.7* versions handled here + # old servers send a reconnect port number + return 'read error' unless read(S1, $buffer, 2) == 2; + my ($reconnect) = unpack('n', $buffer); + $minor = $minor * 10 + $something; # quit if rejected return 'rejected by server' if ($reconnect == 0); @@ -223,7 +298,7 @@ sub BZFlag::querytext { close(S1); # send game request - print S pack("n2", 0, 0x7167); + print S pack('n2', 0, 0x7167); # get reply return 'server read error' unless read(S, $buffer, 40) == 40; @@ -231,21 +306,21 @@ sub BZFlag::querytext { $rogueSize,$redSize,$greenSize,$blueSize,$purpleSize, $rogueMax,$redMax,$greenMax,$blueMax,$purpleMax, $shakeWins,$shakeTimeout, - $maxPlayerScore,$maxTeamScore,$maxTime) = unpack("n20", $buffer); + $maxPlayerScore,$maxTeamScore,$maxTime) = unpack('n20', $buffer); return 'bad server data' unless $infocode == 0x7167; # send players request - print S pack("n2", 0, 0x7170); + print S pack('n2', 0, 0x7170); # get number of teams and players we'll be receiving return 'count read error' unless read(S, $buffer, 8) == 8; - my ($countlen,$countcode,$numTeams,$numPlayers) = unpack("n4", $buffer); + my ($countlen,$countcode,$numTeams,$numPlayers) = unpack('n4', $buffer); return 'bad count data' unless $countcode == 0x7170; # get the teams for (1..$numTeams) { return 'team read error' unless read(S, $buffer, 14) == 14; - my ($teamlen,$teamcode,$team,$size,$aSize,$won,$lost) = unpack("n7", $buffer); + my ($teamlen,$teamcode,$team,$size,$aSize,$won,$lost) = unpack('n7', $buffer); return 'bad team data' unless $teamcode == 0x7475; if ($size > 0) { my $score = $won - $lost; @@ -268,17 +343,17 @@ sub BZFlag::querytext { # close socket close(S); - } else { - $response = 'incompatible version'; + } else { + $response = "incompatible version: $version"; } return $response; } -sub BZFlag::query { +sub query { my ($servernameport) = @_; &::performStrictReply(&querytext($servernameport)); - return; + return; } 1;