File Coverage

blib/lib/POE/Component/Client/Halo.pm

Criterion	Covered	Total	%
statement	21	193	10.8
branch	0	66	0.0
condition	0	56	0.0
subroutine	7	21	33.3
pod	2	13	15.3
total	30	349	8.6

package POE::Component::Client::Halo;

use strict;

use vars qw($VERSION);
$VERSION = '0.2';

sub DEBUG ()  { 0 };

use Carp qw(croak);
use Socket;
use Data::Dumper;
use POE qw(Session Wheel::SocketFactory);

use vars qw(@ISA @EXPORT_OK %EXPORT_TAGS
            $player_flags $game_flags);
@ISA = 'Exporter';
@EXPORT_OK = qw(halo_player_flag halo_game_flag);
%EXPORT_TAGS = (
    'flags' => [qw(halo_player_flag halo_game_flag)],
);

$player_flags = {
    'NumberOfLives'     => ['Infinite', 1, 3, 5],
    'MaximumHealth'     => ['50%', '100%', '150%', '200%', '300%', '400%'],
    'Shields'           => [1, 0],
    'RespawnTime'       => [0, 5, 10, 15],
    'RespawnGrowth'     => [0, 5, 10, 15],
    'OddManOut'         => [0, 1],
    'InvisiblePlayers'  => [0, 1],
    'SuicidePenalty'    => [0, 5, 10, 15],
    'InfiniteGrenades'  => [0, 1],
    'WeaponSet'         => ['Normal', 'Pistols', 'Rifles', 'Plasma', 'Sniper',
                            'No Sniping', 'Rocket Launchers', 'Shotguns',
                            'Short Range', 'Human', 'Covenant', 'Classic',
                            'Heavy Weapons'],
    'StartingEquipment' => ['Custom', 'Generic'],
    'Indicator'         => ['Motion Tracker', 'Nav Points', 'None'],
    'OtherPlayersOnRadar'   => ['No', 'All', undef, 'Friends'],
    'FriendIndicators'  => [0, 1],
    'FriendlyFire'      => ['Off', 'On', 'Shields Only', 'Explosives Only'],
    'FriendlyFirePenalty'   => [0, 5, 10, 15],
    'AutoTeamBalance'   => [0, 1],

    # Team Flags
    'VehicleRespawn'    => [0, 30, 60, 90, 120, 180, 300],
    'RedVehicleSet'     => ['Default', undef, 'Warthogs', 'Ghosts',
                            'Scorpions', 'Rocket Warthogs', 'Banshees',
                            'Gun Turrets', 'Custom'],
    'BlueVehicleSet'     => ['Default', undef, 'Warthogs', 'Ghosts',
                            'Scorpions', 'Rocket Warthogs', 'Banshees',
                            'Gun Turrets', 'Custom'],
};

$game_flags = {
    'GameType'          => ['Capture the Flag', 'Slayer', 'Oddball',
                            'King of the Hill', 'Race'],
    # CTF
    'Assault'           => [0, 1],
    'FlagMustReset'     => [0, 1],
    'FlagAtHomeToScore' => [0, 1],
    'SingleFlag'        => [0, 60, 120, 180, 300, 600],
    # Slayer
    'DeathBonus'        => [1, 0],
    'KillPenalty'       => [1, 0],
    'KillInOrder'       => [0, 1],
    # Oddball
    'RandomStart'       => [0, 1],
    'SpeedWithBall'     => ['Slow', 'Normal', 'Fast'],
    'TraitWithBall'     => ['None', 'Invisible', 'Extra Damage', 'Damage Resistant'],
    'TraitWithoutBall'  => ['None', 'Invisible', 'Extra Damage', 'Damage Resistant'],
    'BallType'          => ['Normal', 'Reverse Tag', 'Juggernaut'],
    'BallSpawnCount'    => [1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16],
    # King of the Hill
    'MovingHill'        => [0, 1],
    # Race
    'RaceType'          => ['Normal', 'Any Order', 'Rally'],
    'TeamScoring'       => ['Minimum', 'Maximum', 'Sum'],
};

sub new {
    my $type = shift;
    my $self = bless {}, $type;

    croak "$type requires an event number of parameters" if @_ % 2;

    my %params = @_;

    my $alias = delete $params{Alias};
    $alias = 'halo' unless defined $alias;

    my $timeout = delete $params{Timeout};
    $timeout = 15 unless defined $timeout and $timeout >= 0;

    my $retry = delete $params{Retry};
    $retry = 2 unless defined $retry and $retry >= 0;

    croak "$type doesn't know these parameters: ", join(', ', sort(keys(%params))) if scalar(keys(%params));

    POE::Session->create(
        inline_states => {
            _start            => \&_start,
            info            => \&info,
            detail          => \&detail,

            got_socket        => \&got_socket,
            got_response        => \&got_response,
            response_timeout    => \&response_timeout,
            debug_heap        => \&debug_heap,

            got_error        => \&got_error,
        },
        args => [ $timeout, $retry, $alias ],
    );

    return $self;
}

sub got_error {
    my ($operation, $errnum, $errstr, $wheel_id, $heap) = @_[ARG0..ARG3,HEAP];
    warn "Wheel $wheel_id generated $operation error $errnum: $errstr\n";
    delete $heap->{w_jobs}->{$wheel_id}; # shut down that wheel
}

sub debug_heap {
    my ($kernel, $heap) = @_[KERNEL, HEAP];
    open(F, ">/tmp/halo-debug") || return;
    print F Dumper($heap);
    close(F) || return;
    $kernel->delay('debug_heap', 10);
}

sub _start {
    my ($kernel, $heap, $timeout, $retry, $alias) = @_[KERNEL, HEAP, ARG0..ARG3];
    $heap->{timeout} = $timeout;
    $heap->{retry} = $retry;
    $kernel->alias_set($alias);
    print STDERR "Halo object started.\n" if DEBUG;
    $kernel->yield('debug_heap') if DEBUG;
}

sub info {
    my ($kernel, $heap, $sender, $ip, $port, $postback) = @_[KERNEL, HEAP, SENDER, ARG0..ARG2];
    my ($identifier) = defined($_[ARG3]) ? $_[ARG3] : undef;
    print STDERR "Got request for $ip:$port info with postback $postback\n" if DEBUG;
    croak "IP address required to execute a query" unless defined $ip;
    croak "Port requred to execute a query" if !defined $port || $port !~ /^\d+$/;
    my $wheel = POE::Wheel::SocketFactory->new(
            RemoteAddress    => $ip,
            RemotePort    => $port,
            SocketProtocol    => 'udp',
            SuccessEvent    => 'got_socket',
            FailureEvent    => 'got_error',
    );
    $heap->{w_jobs}->{$wheel->ID()} = {
        ip        => $ip,
        port        => $port,
        postback    => $postback,
        session        => $sender->ID(),
        wheel        => $wheel,
        identifier    => $identifier,
        try        => 1,    # number of tries...
        action        => 'info',
    };
    return undef;
}

sub detail {
    my ($kernel, $heap, $sender, $ip, $port, $postback) = @_[KERNEL, HEAP, SENDER, ARG0..ARG2];
    my ($identifier) = defined($_[ARG3]) ? $_[ARG3] : undef;
    print STDERR "Got request for $ip:$port players with postback $postback\n" if DEBUG;
    croak "IP address required to execute a query" unless defined $ip;
    croak "Port requred to execute a query" if !defined $port || $port !~ /^\d+$/;
    my $wheel = POE::Wheel::SocketFactory->new(
            RemoteAddress    => $ip,
            RemotePort    => $port,
            SocketProtocol    => 'udp',
            SuccessEvent    => 'got_socket',
            FailureEvent    => 'got_error',
    );
    $heap->{w_jobs}->{$wheel->ID()} = {
        ip        => $ip,
        port        => $port,
        postback    => $postback,
        session        => $sender->ID(),
        wheel        => $wheel,
        identifier    => $identifier,
        try        => 1,    # number of tries...
        action        => 'detail',
    };
    return undef;
}

sub got_socket {
    my ($kernel, $heap, $socket, $wheelid) = @_[KERNEL, HEAP, ARG0, ARG3];

    $heap->{jobs}->{$socket} = delete($heap->{w_jobs}->{$wheelid});
    $kernel->select_read($socket, 'got_response');
    my $query = '';
    if($heap->{jobs}->{$socket}->{action} eq 'info') {
        $query = "\x9c\xb7\x70\x02\x0a\x01\x03\x08\x0a\x05\x06\x13\x33\x36\x0c\x00\x00";
    } elsif($heap->{jobs}->{$socket}->{action} eq 'detail') {
        $query = "\x33\x8f\x02\x00\xff\xff\xff";
    } else {
        die("Unknown action!");
    }
    send($socket, "\xFE\xFD\x00" . $query, 0);
    $heap->{jobs}->{$socket}->{timer} = $kernel->delay_set('response_timeout', $heap->{timeout}, $socket);
    print STDERR "Wheel $wheelid got socket and sent request\n" if DEBUG;
}

sub got_response {
    my ($kernel, $heap, $socket) = @_[KERNEL, HEAP, ARG0];

    my $action = $heap->{jobs}->{$socket}->{action};

    $kernel->select_read($socket);
    $kernel->alarm_remove($heap->{jobs}->{$socket}->{timer}) if defined $heap->{jobs}->{$socket}->{timer};
    delete $heap->{jobs}->{$socket}->{timer};
    my $rsock = recv($socket, my $response = '', 16384, 0);

    my %data;
    if($response eq '') {
        $data{ERROR} = 'DOWN';
    } elsif($action eq 'info') {
        $response = substr($response, 5);
        my @parts = split(/\x00/, $response);
        $data{'Hostname'} = $parts[0];
        $data{'Version'} = $parts[1];
        $data{'Players'} = $parts[2];
        $data{'MaxPlayers'} = $parts[3];
        $data{'Map'} = $parts[4];
        $data{'Mode'} = $parts[5];
        $data{'Password'} = $parts[6];
        $data{'Dedicated'} = $parts[7];
        $data{'Classic'} = $parts[8];
        $data{'Teamplay'} = $parts[9];
    } elsif($action eq 'detail') {
        $response =~ s/\x00+$//;
        my ($rules, $players, $score) = ($response =~ /^.{5}(.+?)\x00{3}[\x00-\x10](.+)\x00{2}[\x02\x00](.+$)/);
        my @parts = split(/\x00/, $response);
        %{$data{'Rules'}} = split(/\x00/, $rules);
        $data{'PlayerFlags'} = decode_player_flags($data{'Rules'}{'player_flags'});
        $data{'GameFlags'} = decode_game_flags($data{'Rules'}{'game_flags'});
        $data{'Players'} = process_segment($players);
        $data{'Score'} = process_segment($score);
    } else {
        die("Unknown request!");
    }

    $kernel->post($heap->{jobs}->{$socket}->{session},
              $heap->{jobs}->{$socket}->{postback},
              $heap->{jobs}->{$socket}->{ip},
              $heap->{jobs}->{$socket}->{port},
              $heap->{jobs}->{$socket}->{action},
              $heap->{jobs}->{$socket}->{identifier},
              \%data);
    delete($heap->{jobs}->{$socket});
}

sub decode_player_flags {
    my $str = shift;
    my $flags = { };
    return $flags if $str eq '' || $str !~ /^\d+\,\d+$/;

    my ($player, $vehicle) = split(/\,/, $str);

    $flags->{'Player'}->{'NumberOfLives'} = $player & 3;
    $flags->{'Player'}->{'MaximumHealth'} = ($player >> 2) & 7;
    $flags->{'Player'}->{'Shields'} = ($player >> 5) & 1;
    $flags->{'Player'}->{'RespawnTime'} = ($player >> 6) & 3;
    $flags->{'Player'}->{'RespawnGrowth'} = ($player >> 8) & 3;
    $flags->{'Player'}->{'OddManOut'} = ($player >> 10) & 1;
    $flags->{'Player'}->{'InvisiblePlayers'} = ($player >> 11) & 1;
    $flags->{'Player'}->{'SuicidePenalty'} = ($player >> 12) & 3;
    $flags->{'Player'}->{'InfiniteGrenades'} = ($player >> 14) & 1;
    $flags->{'Player'}->{'WeaponSet'} = ($player >> 15) & 15;
    $flags->{'Player'}->{'StartingEquipment'} = ($player >> 19) & 1;
    $flags->{'Player'}->{'Indicator'} = ($player >> 20) & 3;
    $flags->{'Player'}->{'OtherPlayersOnRadar'} = ($player >> 22) & 3;
    $flags->{'Player'}->{'FriendIndicators'} = ($player >> 24) & 1;
    $flags->{'Player'}->{'FriendlyFire'} = ($player >> 25) & 3;
    $flags->{'Player'}->{'FriendlyFirePenalty'} = ($player >> 27) & 3;
    $flags->{'Player'}->{'AutoTeamBalance'} = ($player >> 29) & 1;

    $flags->{'Team'}->{'VehicleRespawn'} = ($vehicle & 7);
    $flags->{'Team'}->{'RedVehicleSet'} = ($vehicle >> 3) & 15;
    $flags->{'Team'}->{'BlueVehicleSet'} = ($vehicle >> 7) & 15;

    return $flags;
}

sub decode_game_flags {
    my $str = shift;
    my $flags = { };
    return $flags if $str eq '' || $str !~ /^\d+$/;

    $flags->{'GameType'} = $str & 7;
    if($flags->{'GameType'} == 1) { # CTF
        $flags->{'Assault'} = ($str >> 3) && 1;
        $flags->{'FlagMustReset'} = ($str >> 5) && 1;
        $flags->{'FlagAtHomeToScore'} = ($str >> 6) && 1;
        $flags->{'SingleFlag'} = ($str >> 7) && 7;
    } elsif($flags->{'GameType'} == 2) {    # Slayer
        $flags->{'DeathBonus'} = ($str >> 3) && 1;
        $flags->{'KillPenalty'} = ($str >> 5) && 1;
        $flags->{'KillInOrder'} = ($str >> 6) && 1;
    } elsif($flags->{'GameType'} == 3) {    # Oddball
        $flags->{'RandomStart'} = ($str >> 3) && 1;
        $flags->{'SpeedWithBall'} = ($str >> 5) && 3;
        $flags->{'TraitWithBall'} = ($str >> 7) && 3;
        $flags->{'TraitWithoutBall'} = ($str >> 9) && 3;
        $flags->{'BallType'} = ($str >> 11) && 3;
        $flags->{'BallSpawnCount'} = ($str >> 13) && 31;
    } elsif($flags->{'GameType'} == 4) {    # Hill
        $flags->{'MovingHill'} = ($str >> 3) && 1;
    } elsif($flags->{'GameType'} == 5) {    # Race
        $flags->{'RaceType'} = ($str >> 3) && 3;
        $flags->{'TeamScoring'} = ($str >> 5) && 3;
    }

    return $flags;
}

sub halo_player_flag {
    my ($flag_name, $flag_value) = (shift, shift);

    if(defined($player_flags->{$flag_name}) &&
       defined($player_flags->{$flag_name}->[$flag_value])) {
        return $player_flags->{$flag_name}->[$flag_value];
    } else {
        return undef;
    }
}

sub halo_game_flag {
    my ($flag_name, $flag_value) = (shift, shift);

    if(defined($game_flags->{$flag_name}) &&
       defined($game_flags->{$flag_name}->[$flag_value])) {
        return $game_flags->{$flag_name}->[$flag_value];
    } else {
        return undef;
    }
}

sub response_timeout {
    my ($kernel, $heap, $socket) = @_[KERNEL, HEAP, ARG0];
    if($heap->{jobs}->{$socket}->{try} > ($heap->{retry} + 1)) {
        $kernel->post($heap->{jobs}->{$socket}->{session}, $heap->{jobs}->{$socket}->{postback},
                $heap->{jobs}->{$socket}->{ip},
                $heap->{jobs}->{$socket}->{port},
                $heap->{jobs}->{$socket}->{action},
                $heap->{jobs}->{$socket}->{identifier},
                { 'ERROR' => 'Timed out waiting for a response.'});
        delete($heap->{jobs}->{$socket});
    } else {
        print STDERR "Query timed out for $socket.  Retrying.\n" if DEBUG;
        my $query = '';
        if($heap->{jobs}->{$socket}->{action} eq 'info') {
            $query = "\x9c\xb7\x70\x02\x0a\x01\x03\x08\x0a\x05\x06\x13\x33\x36\x0c\x00\x00";
        } elsif($heap->{jobs}->{$socket}->{action} eq 'detail') {
            $query = "\x33\x8f\x02\x00\xff\xff\xff";
        } else {
            die("Unknown action!");
        }
        send($socket, "\xFE\xFD\x00" . $query, 0);
        $heap->{jobs}->{$socket}->{timer} = $kernel->delay_set('response_timeout', $heap->{timeout}, $socket);
        $heap->{jobs}->{$socket}->{try}++;
    }
}

sub process_segment {
    my $str = shift;

    my @parts = split(/\x00/, $str);
    my @fields = ();
    foreach(@parts) {
        last if $_ eq '';
        s/_.*$//;
        push(@fields, $_);
    }
    my $info = {};
    my $ctr = 0;
    my $cur_item = '';
    foreach(splice(@parts, scalar(@fields) + 1)) {
        if($ctr % scalar(@fields) == 0) {
            $cur_item = $_;
            $info->{$cur_item}->{$fields[0]} = $cur_item;
        } else {
            $info->{$cur_item}->{$fields[$ctr % scalar(@fields)]} = $_;
        }
        $ctr++;
    }
    return $info;
}

1;

__END__