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


line stmt bran cond sub pod time code
1             package Net::SRCDS::Queries;
2              
3 3     3   95684 use warnings;
  3         7  
  3         101  
4 3     3   15 use strict;
  3         7  
  3         65  
5 3     3   1919 use version; our $VERSION = qv('0.0.4');
  3         6140  
  3         17  
6 3     3   251 use Carp qw(croak);
  3         5  
  3         188  
7 3     3   1671 use IO::Socket::INET;
  3         52992  
  3         24  
8 3     3   4380 use IO::Select;
  3         5010  
  3         145  
9 3     3   17 use base qw(Net::SRCDS::Queries::Parser);
  3         7  
  3         2181  
10              
11             # implemented queries
12             # see http://developer.valvesoftware.com/wiki/Source_Server_Queries
13             # for all queries.
14             #
15 3     3   16 use constant GETCHALLENGE => "\xFF\xFF\xFF\xFF\x57";
  3         13  
  3         174  
16 3     3   15 use constant A2S_INFO => "\xFF\xFF\xFF\xFFTSource Engine Query\0";
  3         6  
  3         150  
17 3     3   16 use constant A2S_PLAYER => "\xFF\xFF\xFF\xFF\x55";
  3         4  
  3         152  
18 3     3   12 use constant A2S_RULES => "\xFF\xFF\xFF\xFF\x56";
  3         6  
  3         130  
19 3     3   14 use constant MAX_SOCKBUF => 65535;
  3         6  
  3         2295  
20              
21             sub new {
22 2     2 1 349 my( $class, %args ) = @_;
23              
24             my $socket = IO::Socket::INET->new(
25             Proto => 'udp',
26             Blocking => 0,
27 2 50 50     41 LocalPort => $args{LocalPort} || 27015,
28             ) or croak "cannot bind socket : $!";
29 2         548 my $select = IO::Select->new($socket);
30             my $self = {
31             socket => $socket,
32             select => $select,
33             servers => [],
34             timeout => $args{timeout} || 3,
35             encoding => $args{encoding} || undef,
36 2   50     166 };
      50        
37             $self->{float_order} =
38 2 50       16 unpack( 'H*', pack( 'f', 1.05 ) ) eq '6666863f' ? 0 : 1;
39 2         10 bless $self, $class;
40             }
41              
42             sub add_server {
43 0     0 1 0 my( $self, $addr, $port ) = @_;
44 0         0 push @{ $self->{servers} }, { addr => $addr, port => $port };
  0         0  
45             }
46              
47             sub get_all {
48 0     0 1 0 my($self) = @_;
49 0         0 my $select = $self->{select};
50 0         0 my $timeout = $self->{timeout};
51 0         0 for my $s ( @{ $self->{servers} } ) {
  0         0  
52 0         0 my $dest = sockaddr_in $s->{port}, inet_aton $s->{addr};
53 0         0 $self->send_a2s_info($dest);
54 0         0 $self->send_challenge($dest);
55             }
56 0         0 my $finished = {};
57 0         0 LOOP: while (1) {
58 0         0 my @ready = $select->can_read($timeout);
59 0         0 for my $fh (@ready) {
60 0         0 my $sender = $fh->recv( my $buf, MAX_SOCKBUF );
61 0         0 my( $port, $addr ) = sockaddr_in $sender;
62 0         0 my $server = sprintf "%s:%s", inet_ntoa($addr), $port;
63 0         0 my $result = $self->parse_packet( $buf, $server, $sender );
64 0         0 my $sr = $self->{results}->{$server};
65 0 0 0     0 if ( exists $sr->{player} and exists $sr->{rules} ) {
66 0         0 $finished->{$server}++;
67             }
68             last LOOP
69 0 0       0 if scalar keys %{$finished} >= scalar @{ $self->{servers} };
  0         0  
  0         0  
70             }
71             # exit loop when you get nothing
72 0 0       0 unless (@ready) {
73 0         0 warn "no ready\n";
74 0         0 last LOOP;
75             }
76             }
77 0         0 return $self->{results};
78             }
79              
80             sub send_challenge {
81 1     1 1 1486 my( $self, $dest ) = @_;
82 1         5 my $socket = $self->{socket};
83 1         10 $socket->send( GETCHALLENGE, 0, $dest );
84             }
85              
86             sub send_a2s_info {
87 1     1 1 738 my( $self, $dest ) = @_;
88 1         4 my $socket = $self->{socket};
89 1         9 $socket->send( A2S_INFO, 0, $dest );
90             }
91              
92             sub send_a2s_player {
93 1     1 1 931 my( $self, $dest, $cnum ) = @_;
94 1         5 my $socket = $self->{socket};
95 1         9 $socket->send( A2S_PLAYER . $cnum, 0, $dest );
96             }
97              
98             sub send_a2s_rules {
99 1     1 1 3136 my( $self, $dest, $cnum ) = @_;
100 1         5 my $socket = $self->{socket};
101 1         10 $socket->send( A2S_RULES . $cnum, 0, $dest );
102             }
103              
104             sub get_result {
105 0     0 1   my($self) = @_;
106 0           return $self->{results};
107             }
108              
109             1;
110             __END__