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

package Net::SRCDS::Queries::Parser;

use warnings;
use strict;
use version; our $VERSION = qv('0.0.5');
use Encode qw(from_to);

sub parse_packet {
    my( $self, $buf, $server, $sender ) = @_;
    my $t = unpack 'x4a', $buf;
    if ( $t eq 'A' ) {
        my $result = $self->parse_challenge($buf);
        $self->send_a2s_rules( $sender, $result->{cnum} );
        $self->send_a2s_player( $sender, $result->{cnum} );
    }
    elsif ( $t eq 'I' ) {
        my $result = $self->parse_a2s_info($buf);
        $self->{results}->{$server}->{info} = $result;
    }
    elsif ( $t eq 'D' ) {
        my $result = $self->parse_a2s_player($buf);
        $self->{results}->{$server}->{player} = $result;
        return 1;
    }
    elsif ( $t eq 'E' ) {
        my $result = $self->parse_a2s_rules($buf);
        $self->{results}->{$server}->{rules} = $result;
        return 1;
    }
    return 0;
}

sub parse_a2s_info {
    my( $self, $buf ) = @_;
    my( $type, $version, $str ) = unpack 'x4aca*', $buf;
    my( $sname, $map, $dir, $desc, $remains ) = split /\0/, $str, 5;
    my(
        $app_id, $players, $max,    $bots, $dedicated,
        $os,     $pw,      $secure, $remains2
    ) = unpack 'vcccaacca*', $remains;
    my( $gversion, $remains3 ) = split /\0/, $remains2, 2;

    my $result = {
        type      => $type,
        version   => $version,
        sname     => $sname,
        map       => $map,
        dir       => $dir,
        desc      => $desc,
        app_id    => $app_id,
        players   => $players,
        max       => $max,
        bots      => $bots,
        dedicated => $dedicated,
        os        => $os,
        password  => $pw,
        secure    => $secure,
        gversion  => $gversion,
    };
    my( $edf, $opt ) = unpack 'ca*', $remains3;
    if ( $edf & 0x80 ) {
        my $port;
        ( $port, $opt ) = unpack 'va*', $opt;
        $result->{port} = $port;
    }
    if ( $edf & 0x40 ) {
        # print "opt is spectator port\n";
        $result->{spectator} = '';
    }
    if ( $edf & 0x20 ) {
        chop $opt;
        $result->{game_tag} = $opt;
    }
    return $result;
}

sub parse_a2s_player {
    my( $self, $buf ) = @_;
    my $encoding = $self->{encoding};
    my( $type, $num_players, $followings ) = unpack 'x4aca*', $buf;
    my $player_info;
    while ($followings) {
        my( $index, $r1 ) = unpack 'ca*', $followings;
        my( $name, $r2 ) = ( split /\0/, $r1, 2 );
        from_to( $name, 'utf8', $encoding ) if $encoding;
        my( $kills, $connected, $r3 ) = unpack 'lfa*', $r2;
        # XXX : reverse float for some environment
        if ( $self->{float_order} ) {
            my $hex = unpack 'H*', pack 'f', $connected;
            my @b;
            $hex =~ s/(.{2})/push(@b, $1)/seg;
            $hex = join '', reverse @b;
            $connected = unpack 'f', pack 'H*', $hex;
        }
        push @{$player_info},
            {
            name      => $name,
            kills     => $kills,
            connected => $connected,
            };
        $followings = $r3;
    }

    my $result = {
        type        => $type,
        num_players => $num_players,
        player_info => $player_info,
    };
    return $result;
}

sub parse_a2s_rules {
    my( $self, $buf ) = @_;
    my $encoding = $self->{encoding};
    my( $type, $num_rules, $r1 ) = unpack 'x4aca*', $buf;
    my( undef, $followings ) = ( split /\0/, $r1, 2 );
    my $rules_info;
    while ($followings) {
        my( $name, $value, $r2 ) = ( split /\0/, $followings, 3 );
        push @{$rules_info},
            {
            name  => $name,
            value => $value,
            };
        $followings = $r2;
    }

    my $result = {
        type       => $type,
        num_rules  => $num_rules,
        rules_info => $rules_info,
    };
    return $result;
}

sub parse_challenge {
    my( $self, $buf ) = @_;
    my( $type, $cnum ) = unpack 'x4aa4', $buf;
    return {
        type => $type,
        cnum => $cnum,
    };
}

use constant base_number => 76561197960265728;
sub id2community_id {
    my( $self, $id ) = @_;
    my( $n1, $n2, $n3 ) = ( $id =~ /STEAM_(\d):(\d):(\d+)/i );
    return unless defined $n1;
    my $community_id = base_number + $n2 + ( $n3 * 2 );
    return $community_id;
}

1;
__END__