BZFlag::Info - Extracts infomation about BZFlag servers and players

    use BZFlag::Info;

    my $bzinfo = new BZFlag::Info;

    my $serverlist = $bzinfo->serverlist;
    my $serverlist = $bzinfo->serverlist(Proxy => 'host:port', Server => 'http://listserver/');

    my $serverinfo = $bzinfo->queryserver(Server => 'host:port');

package BZFlag::Info;

use 5.006001;
use strict;
use warnings;

use LWP::UserAgent;
use Socket;

our $VERSION = '1.9.2';

sub new {
    my $self = { };
    bless $self, "BZFlag::Info";
    return $self;
}

sub serverlist(%) {
    my $self = shift;
    
    my %options;
    while (my @option = splice(@_, 0, 2)) {
	$options{$option[0]} = $option[1];
    }
    
    my $proxy = $options{Proxy};
    my $response;
    my $ua = new LWP::UserAgent;
    $ua->proxy('http', $proxy) if defined($proxy);
    
    $ua->timeout(10);
    
    my $req = HTTP::Request->new('GET', ($options{Server} ? $options{Server} : $self->listserver));
    my $res = $ua->request($req);
    my $totalServers = 0;
    my $totalPlayers = 0;
    for my $line (split("\n",$res->content)) {
	my ($serverport, $version, $flags, $ip, $description) = split(" ",$line,5);
	
	my @fields = ('style','maxShots','shakeWins','shakeTimeout','maxPlayerScore',
	    'maxTeamScore','maxTime','maxPlayers','rogueSize','rogueMax','redSize',
	    'redMax','greenSize','greenMax','blueSize','blueMax','purpleSize',
	    'purpleMax','observerSize','observerMax'
	    );

	my @info = unpack("(A4)7 (A2)13", $flags);

	my $counter = 0;
	my %info;

	foreach (@fields) {
	    $info{$_} = oct('0x'.$info[$counter]);
	    $counter++;
	}
	
	my $playerSize = $info{rogueSize} + $info{redSize} + $info{greenSize}
	    + $info{blueSize} + $info{purpleSize} + $info{observerSize};
	
	unless ($serverport =~ m/.*:\d+/) {
	    $serverport = "$serverport:5154";
	}
	
	$response->{servers}->{$serverport}->{version}     = $version;
	$response->{servers}->{$serverport}->{ip}          = $ip;
	$response->{servers}->{$serverport}->{description} = $description;
	
	$response->{servers}->{$serverport}->{numplayers}   = $playerSize;
	$response->{servers}->{$serverport}->{roguesize}    = $info{rogueSize};
	$response->{servers}->{$serverport}->{redsize}      = $info{redSize};
	$response->{servers}->{$serverport}->{greensize}    = $info{greenSize};
	$response->{servers}->{$serverport}->{bluesize}     = $info{blueSize};
	$response->{servers}->{$serverport}->{purplesize}   = $info{purpleSize};
	$response->{servers}->{$serverport}->{observersize} = $info{observerSize};

	$response->{servers}->{$serverport}->{serverconfig}->{style}          = $self->parsestyle($info{style});
	$response->{servers}->{$serverport}->{serverconfig}->{maxshots}       = $info{maxShots};
	$response->{servers}->{$serverport}->{serverconfig}->{shakewins}      = $info{shakeWins};
	$response->{servers}->{$serverport}->{serverconfig}->{shaketimeout}   = $info{shakeTimeout} / 10;
	$response->{servers}->{$serverport}->{serverconfig}->{maxplayerscore} = $info{maxPlayerScore};
	$response->{servers}->{$serverport}->{serverconfig}->{maxteamscore}   = $info{maxTeamScore};
	$response->{servers}->{$serverport}->{serverconfig}->{maxtime}        = $info{maxTime};
	$response->{servers}->{$serverport}->{serverconfig}->{maxplayers}     = $info{maxPlayers};
	$response->{servers}->{$serverport}->{serverconfig}->{roguemax}       = $info{rogueMax};
	$response->{servers}->{$serverport}->{serverconfig}->{redmax}         = $info{redMax};
	$response->{servers}->{$serverport}->{serverconfig}->{greenmax}       = $info{greenMax};
	$response->{servers}->{$serverport}->{serverconfig}->{bluemax}        = $info{blueMax};
	$response->{servers}->{$serverport}->{serverconfig}->{purplemax}      = $info{purpleMax};
	$response->{servers}->{$serverport}->{serverconfig}->{observermax}    = $info{observerMax};

	$totalServers += 1;
	$totalPlayers += $playerSize;
    }
    $response->{totalservers} = $totalServers;
    $response->{totalplayers} = $totalPlayers;

    return ($response);

}    

sub queryserver(%) {
    my $self = shift;

    my %options;
    while (my @option = splice(@_, 0, 2)) {
	$options{$option[0]} = $option[1];
    }

    my $hostandport = $options{Server};
    my $timeout = $options{Timeout};

    my @teamName = ("X", "R", "G", "B", "P", "O", "H");
#    my @teamName     = ("X", "R", "G", "B", "P");
    my ($message, $server);
    my $response;
    my ($servername, $port) = split(/:/, $hostandport);
    $port = 5154 unless $port;
    
    # socket define
    my $sockaddr = 'S n a4 x8';
    
    # port to port number
    my ($name,$aliases,$proto) = getprotobyname('tcp');
    ($name,$aliases,$port)  = getservbyname($port,'tcp') unless $port =~ /^\d+$/;
    
    # get server address
    my ($type,$len,$serveraddr);
    ($name,$aliases,$type,$len,$serveraddr) = gethostbyname($servername);
    $server = pack($sockaddr, AF_INET, $port, $serveraddr);
    
    # connect
    unless (socket(S, AF_INET, SOCK_STREAM, $proto)) {
	$self->{error} = 'errSocketError';
	return undef;
    }

    unless (connect(S, $server)) {
	$self->{error} = "errCouldNotConnect: $servername:$port";
	return undef;
    }
    
    # don't buffer
    select(S); $| = 1; select(STDOUT);
    
    # get hello
    my $buffer;
    unless (read(S, $buffer, 9) == 9) {
	$self->{error} = 'errReadError';
	return undef;
    }

    # parse reply
    my ($magic, $version, $id) = unpack("a4 a4 C1", $buffer);
    
    # quit if version isn't valid
    if ($magic ne "BZFS") {
	$self->{error} = 'errNotABzflagServer';
	return undef;
    }

    # try incompatible for 1.7, etc.
    if ($version != '1910') {
	$self->{error} = 'errIncompatibleVersion';
	return undef;
    }
    
    # send game request
    print S pack("n2", 0, 0x7167);
    
    # get reply
    unless (read(S, $buffer, 40) == 40) {
	$self->{error} = 'errServerReadError';
	return undef;
    }

    my ($infolen,$infocode,$style,$maxPlayers,$maxShots,
	$rogueSize,$redSize,$greenSize,$blueSize,$purpleSize,
	$rogueMax,$redMax,$greenMax,$blueMax,$purpleMax,
	$shakeWins,$shakeTimeout,
	$maxPlayerScore,$maxTeamScore,$maxTime) = unpack("n20", $buffer);

    unless ($infocode == 0x7167) {
	$self->{error} = 'errBadServerData';
	return undef;
    }

    $response->{serverconfig}->{style} = $self->parsestyle($style);

    $response->{serverconfig}->{maxplayers} = $maxPlayers;
    $response->{serverconfig}->{maxshots} = $maxShots;
    $response->{serverconfig}->{roguemax} = $rogueMax;
    $response->{serverconfig}->{redmax} = $redMax;
    $response->{serverconfig}->{greenmax} = $greenMax;
    $response->{serverconfig}->{bluemax} = $blueMax;
    $response->{serverconfig}->{purplemax} = $purpleMax;
    $response->{serverconfig}->{shakewins} = $shakeWins;
    $response->{serverconfig}->{shaketimeout} = $shakeTimeout;
    $response->{serverconfig}->{maxplayerscore} = $maxPlayerScore;
    $response->{serverconfig}->{maxteamscore} = $maxTeamScore;
    $response->{serverconfig}->{maxtime} = $maxTime;

    # send players request
    print S pack("n2", 0, 0x7170);
    
    # get number of teams and players we'll be receiving
    unless (read(S, $buffer, 8) == 8) {
	$self->{error} = 'errCountReadError';
	return undef;
    }

    my ($countlen,$countcode,$numTeams,$numPlayers) = unpack("n4", $buffer);
    unless ($countcode == 0x7170) {
	$self->{error} = 'errBadCountData';
	return undef;
    }

    $response->{numplayers} = $numPlayers;

    unless (read(S, $buffer, 5) == 5) {
	$self->{error} = 'errCountReadError';
	return undef;
    }

    my ($countlen2, $countcode2, $numTeams2) = unpack("n2 C", $buffer);
    unless ($countcode2 == 0x7475) {
	$self->{error} = 'errBadCountData';
        return undef;
    }

    $response->{numteams} = $numTeams2;

    # get the teams
    for (1..$numTeams2) {
	unless (read(S, $buffer, 8) == 8) {
	    $self->{error} = 'errTeamReadError';
	    return undef;
	}

	my ($team, $size, $wins, $losses) = unpack("n4", $buffer);

	my $score = $wins - $losses;

	$response->{teams}->{$teamName[$team]}->{size}   = $size;
	$response->{teams}->{$teamName[$team]}->{score}  = $score;
	$response->{teams}->{$teamName[$team]}->{wins}   = $wins;
	$response->{teams}->{$teamName[$team]}->{losses} = $losses;
	
    }
    
    # get the players
    for (1..$numPlayers) {
	next unless (read(S, $buffer, 175) == 175);
	my ($len, $code, $pID, $type, $team, $wins, $losses, $tks, $callsign, $email) = 
	    unpack("n2 C n5 A32 A128", $buffer);

	unless ($code == 0x6170) {
	    $self->{error} = 'errBadPlayerData';
	    return undef;
	}

	my $score = $wins - $losses;

	$response->{players}->{$callsign}->{team}   = $teamName[$team];
	$response->{players}->{$callsign}->{email}  = $email;
	$response->{players}->{$callsign}->{score}  = $score;
	$response->{players}->{$callsign}->{wins}   = $wins;
	$response->{players}->{$callsign}->{losses} = $losses;
	$response->{players}->{$callsign}->{tks}    = $tks;
	$response->{players}->{$callsign}->{pID}    = $pID;

    }
    if ($numPlayers <= 1) {
	$self->{error} = 'errNoPlayers';
	return undef;
    }
    
    # close socket
    close(S);
    
    return $response;

}

sub parsestyle ($) {
    my $self = shift;
    my $style = shift;

    my $response;

    if ($style & 0x0001) { 
	$response->{ctf} = 1;
    } else {
	$response->{ctf} = 0;
    }
    
    if ($style & 0x0002) { 
	$response->{superflags} = 1;
    } else {
	$response->{superflags} = 0;
    }
    
    if ($style & 0x0004) { 
	$response->{rogues} = 1;
    } else {
	$response->{rogues} = 0;
    }
    
    if ($style & 0x0008) { 
	$response->{jumping} = 1;
    } else {
	$response->{jumping} = 0;
    }
    
    if ($style & 0x0010) { 
	$response->{inertia} = 1;
    } else {
	$response->{inertia} = 0;
    }
    
    if ($style & 0x0020) { 
	$response->{ricochet} = 1;
    } else {
	$response->{ricochet} = 0;
    }
    
    if ($style & 0x0040) { 
	$response->{shakable} = 1;
    } else {
	$response->{shakable} = 0;
    }
    
    if ($style & 0x0080) { 
	$response->{antidoteflags} = 1;
    } else {
	$response->{antidoteflags} = 0;
    }
    
    if ($style & 0x0100) { 
	$response->{timesync} = 1;
    } else {
	$response->{timesync} = 0;
    }
    
    if ($style & 0x0200) { 
	$response->{rabbitchase} = 1;
    } else {
	$response->{rabbitchase} = 0;
    }

    return $response;
}

sub geterror {
    my $self = shift;
    return $self->{error};
}

sub listserver {
    my $self = shift;
    return "http://list.bzflag.bz/db/";
}

1;

__END__