File Coverage

blib/lib/Net/SRCDS/Queries/Parser.pm
Criterion Covered Total %
statement 61 88 69.3
branch 5 20 25.0
condition n/a
subroutine 9 11 81.8
pod 6 6 100.0
total 81 125 64.8


line stmt bran cond sub pod time code
1             package Net::SRCDS::Queries::Parser;
2              
3 3     3   18 use warnings;
  3         5  
  3         95  
4 3     3   15 use strict;
  3         5  
  3         57  
5 3     3   29 use version; our $VERSION = qv('0.0.5');
  3         5  
  3         19  
6 3     3   2643 use Encode qw(from_to);
  3         33193  
  3         2911  
7              
8             sub parse_packet {
9 0     0 1 0 my( $self, $buf, $server, $sender ) = @_;
10 0         0 my $t = unpack 'x4a', $buf;
11 0 0       0 if ( $t eq 'A' ) {
    0          
    0          
    0          
12 0         0 my $result = $self->parse_challenge($buf);
13 0         0 $self->send_a2s_rules( $sender, $result->{cnum} );
14 0         0 $self->send_a2s_player( $sender, $result->{cnum} );
15             }
16             elsif ( $t eq 'I' ) {
17 0         0 my $result = $self->parse_a2s_info($buf);
18 0         0 $self->{results}->{$server}->{info} = $result;
19             }
20             elsif ( $t eq 'D' ) {
21 0         0 my $result = $self->parse_a2s_player($buf);
22 0         0 $self->{results}->{$server}->{player} = $result;
23 0         0 return 1;
24             }
25             elsif ( $t eq 'E' ) {
26 0         0 my $result = $self->parse_a2s_rules($buf);
27 0         0 $self->{results}->{$server}->{rules} = $result;
28 0         0 return 1;
29             }
30 0         0 return 0;
31             }
32              
33             sub parse_a2s_info {
34 1     1 1 1000594 my( $self, $buf ) = @_;
35 1         13 my( $type, $version, $str ) = unpack 'x4aca*', $buf;
36 1         33 my( $sname, $map, $dir, $desc, $remains ) = split /\0/, $str, 5;
37             my(
38 1         9 $app_id, $players, $max, $bots, $dedicated,
39             $os, $pw, $secure, $remains2
40             ) = unpack 'vcccaacca*', $remains;
41 1         8 my( $gversion, $remains3 ) = split /\0/, $remains2, 2;
42              
43 1         28 my $result = {
44             type => $type,
45             version => $version,
46             sname => $sname,
47             map => $map,
48             dir => $dir,
49             desc => $desc,
50             app_id => $app_id,
51             players => $players,
52             max => $max,
53             bots => $bots,
54             dedicated => $dedicated,
55             os => $os,
56             password => $pw,
57             secure => $secure,
58             gversion => $gversion,
59             };
60 1         6 my( $edf, $opt ) = unpack 'ca*', $remains3;
61 1 50       11 if ( $edf & 0x80 ) {
62 1         11 my $port;
63 1         7 ( $port, $opt ) = unpack 'va*', $opt;
64 1         9 $result->{port} = $port;
65             }
66 1 50       7 if ( $edf & 0x40 ) {
67             # print "opt is spectator port\n";
68 0         0 $result->{spectator} = '';
69             }
70 1 50       6 if ( $edf & 0x20 ) {
71 1         3 chop $opt;
72 1         5 $result->{game_tag} = $opt;
73             }
74 1         7 return $result;
75             }
76              
77             sub parse_a2s_player {
78 1     1 1 1000514 my( $self, $buf ) = @_;
79 1         7 my $encoding = $self->{encoding};
80 1         15 my( $type, $num_players, $followings ) = unpack 'x4aca*', $buf;
81 1         4 my $player_info;
82 1         12 while ($followings) {
83 1         6 my( $index, $r1 ) = unpack 'ca*', $followings;
84 1         9 my( $name, $r2 ) = ( split /\0/, $r1, 2 );
85 1 50       7 from_to( $name, 'utf8', $encoding ) if $encoding;
86 1         8 my( $kills, $connected, $r3 ) = unpack 'lfa*', $r2;
87             # XXX : reverse float for some environment
88 1 50       10 if ( $self->{float_order} ) {
89 0         0 my $hex = unpack 'H*', pack 'f', $connected;
90 0         0 my @b;
91 0         0 $hex =~ s/(.{2})/push(@b, $1)/seg;
  0         0  
92 0         0 $hex = join '', reverse @b;
93 0         0 $connected = unpack 'f', pack 'H*', $hex;
94             }
95 1         3 push @{$player_info},
  1         10  
96             {
97             name => $name,
98             kills => $kills,
99             connected => $connected,
100             };
101 1         7 $followings = $r3;
102             }
103              
104 1         9 my $result = {
105             type => $type,
106             num_players => $num_players,
107             player_info => $player_info,
108             };
109 1         7 return $result;
110             }
111              
112             sub parse_a2s_rules {
113 1     1 1 1000528 my( $self, $buf ) = @_;
114 1         6 my $encoding = $self->{encoding};
115 1         15 my( $type, $num_rules, $r1 ) = unpack 'x4aca*', $buf;
116 1         11 my( undef, $followings ) = ( split /\0/, $r1, 2 );
117 1         7 my $rules_info;
118 1         10 while ($followings) {
119 64         354 my( $name, $value, $r2 ) = ( split /\0/, $followings, 3 );
120 64         140 push @{$rules_info},
  64         309  
121             {
122             name => $name,
123             value => $value,
124             };
125 64         256 $followings = $r2;
126             }
127              
128 1         14 my $result = {
129             type => $type,
130             num_rules => $num_rules,
131             rules_info => $rules_info,
132             };
133 1         7 return $result;
134             }
135              
136             sub parse_challenge {
137 1     1 1 1000569 my( $self, $buf ) = @_;
138 1         15 my( $type, $cnum ) = unpack 'x4aa4', $buf;
139             return {
140 1         13 type => $type,
141             cnum => $cnum,
142             };
143             }
144              
145 3     3   22 use constant base_number => 76561197960265728;
  3         4  
  3         443  
146             sub id2community_id {
147 0     0 1   my( $self, $id ) = @_;
148 0           my( $n1, $n2, $n3 ) = ( $id =~ /STEAM_(\d):(\d):(\d+)/i );
149 0 0         return unless defined $n1;
150 0           my $community_id = base_number + $n2 + ( $n3 * 2 );
151 0           return $community_id;
152             }
153              
154             1;
155             __END__