File Coverage

blib/lib/Net/SRCDS/Queries.pm

Criterion	Covered	Total	%
statement	54	85	63.5
branch	2	10	20.0
condition	3	9	33.3
subroutine	17	20	85.0
pod	8	8	100.0
total	84	132	63.6

package Net::SRCDS::Queries;

use warnings;
use strict;
use version; our $VERSION = qv('0.0.5');
use Carp qw(croak);
use IO::Socket::INET;
use IO::Select;
use base qw(Net::SRCDS::Queries::Parser);

# implemented queries
# see http://developer.valvesoftware.com/wiki/Source_Server_Queries
# for all queries.
#
use constant GETCHALLENGE => "\xFF\xFF\xFF\xFF\x57";
use constant A2S_INFO     => "\xFF\xFF\xFF\xFFTSource Engine Query\0";
use constant A2S_PLAYER   => "\xFF\xFF\xFF\xFF\x55";
use constant A2S_RULES    => "\xFF\xFF\xFF\xFF\x56";
use constant MAX_SOCKBUF  => 65535;

sub new {
    my( $class, %args ) = @_;

    my $socket = IO::Socket::INET->new(
        Proto    => 'udp',
        Blocking => 0,
        LocalPort => $args{LocalPort} || 0,
    ) or croak "cannot bind socket : $!";
    my $select = IO::Select->new($socket);
    my $self   = {
        socket   => $socket,
        select   => $select,
        servers  => [],
        timeout  => $args{timeout} || 3,
        encoding => $args{encoding} || undef,
    };
    $self->{float_order} =
        unpack( 'H*', pack( 'f', 1.05 ) ) eq '6666863f' ? 0 : 1;
    bless $self, $class;
}

sub add_server {
    my( $self, $addr, $port ) = @_;
    push @{ $self->{servers} }, { addr => $addr, port => $port };
}

sub get_all {
    my($self)   = @_;
    my $select  = $self->{select};
    my $timeout = $self->{timeout};
    for my $s ( @{ $self->{servers} } ) {
        my $dest = sockaddr_in $s->{port}, inet_aton $s->{addr};
        $self->send_a2s_info($dest);
        $self->send_challenge($dest);
    }
    my $finished = {};
LOOP: while (1) {
        my @ready = $select->can_read($timeout);
        for my $fh (@ready) {
            my $sender = $fh->recv( my $buf, MAX_SOCKBUF );
            my( $port, $addr ) = sockaddr_in $sender;
            my $server = sprintf "%s:%s", inet_ntoa($addr), $port;
            my $result = $self->parse_packet( $buf, $server, $sender );
            my $sr = $self->{results}->{$server};
            if ( exists $sr->{player} and exists $sr->{rules} ) {
                $finished->{$server}++;
            }
            last LOOP
                if scalar keys %{$finished} >= scalar @{ $self->{servers} };
        }
        # exit loop when you get nothing
        unless (@ready) {
            warn "no ready\n";
            last LOOP;
        }
    }
    return $self->{results};
}

sub send_challenge {
    my( $self, $dest ) = @_;
    my $socket = $self->{socket};
    $socket->send( GETCHALLENGE, 0, $dest );
}

sub send_a2s_info {
    my( $self, $dest ) = @_;
    my $socket = $self->{socket};
    $socket->send( A2S_INFO, 0, $dest );
}

sub send_a2s_player {
    my( $self, $dest, $cnum ) = @_;
    my $socket = $self->{socket};
    $socket->send( A2S_PLAYER . $cnum, 0, $dest );
}

sub send_a2s_rules {
    my( $self, $dest, $cnum ) = @_;
    my $socket = $self->{socket};
    $socket->send( A2S_RULES . $cnum, 0, $dest );
}

sub get_result {
    my($self) = @_;
    return $self->{results};
}

1;
__END__