File Coverage

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

Criterion	Covered	Total	%
statement	18	145	12.4
branch	0	66	0.0
condition	0	27	0.0
subroutine	6	19	31.5
pod	2	12	16.6
total	26	269	9.6

package POE::Component::Client::Rcon;

use strict;

use vars qw($VERSION $playerSN);
$VERSION = '0.23';
$playerSN = 0;

use Carp qw(croak);
use Socket;
use Time::HiRes qw(time);
use POE qw(Session Wheel::SocketFactory);

sub DEBUG ()  { 0 };

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 = 'rcon' 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;

	my $bytes = delete $params{Bytes};
	$bytes = 8192 unless defined $bytes and $bytes > 0;

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

	POE::Session->create(
		inline_states => {
			_start			=> \&_start,
			rcon			=> \&rcon,
			got_socket		=> \&got_socket,
			got_message		=> \&got_message,
			got_error		=> \&got_error,
			got_challenge		=> \&got_challenge,
			got_rcon_response	=> \&got_rcon_response,
			challenge_timeout	=> \&challenge_timeout,
			rcon_timeout		=> \&rcon_timeout,
			players			=> \&players,
			player_response		=> \&player_response,
			player_parse_hl		=> \&player_parse_hl,
			player_parse_quake	=> \&player_parse_quake,
		},
		args => [ $timeout, $retry, $alias, $bytes ],
	);

	return $self;
}

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

sub rcon {
	my ($kernel, $heap, $sender, $type, $ip, $port, $pw, $cmd, $postback) = @_[KERNEL, HEAP, SENDER, ARG0..ARG5];
	my ($identifier) = defined($_[ARG6]) ? $_[ARG6] : undef;
	print STDERR "Got $ip:$port with password $pw running command $cmd with postback $postback\n" if DEBUG;
	croak "IP address required to execute an Rcon command" unless defined $ip;
	croak "Port requred to execute an Rcon command" if !defined $port || $port !~ /^\d+$/;
	croak "Password requires to execute an Rcon command" if !defined $pw || $pw eq '';
	croak "Command required to execute an Rcon command" if !defined $cmd || $cmd eq '';
	croak "Server type was not recognized" unless $type =~ /^(?:qw|q2|q3|oldhl|hl)$/;
	my $challenge = '';
	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,
		pw		=> $pw,
		cmd		=> $cmd,
		postback	=> $postback,
		session		=> $sender->ID(),
		wheel		=> $wheel,
		identifier	=> $identifier,
		type		=> $type,
		try		=> 1,	# number of tries...
	};
	return undef;
}

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 got_socket {
	my ($kernel, $heap, $socket, $wheelid) = @_[KERNEL, HEAP, ARG0, ARG3];

	$heap->{jobs}->{$socket} = delete($heap->{w_jobs}->{$wheelid});
	if($heap->{jobs}->{$socket}->{type} eq 'hl') {
		$kernel->select_read($socket, 'got_challenge');
		send($socket, "\xFF\xFF\xFF\xFFchallenge rcon\n\0", 0);
		$heap->{jobs}->{$socket}->{timer} = $kernel->delay_set('challenge_timeout', $heap->{timeout}, $socket);
		print STDERR "Wheel $wheelid got socket and sent rcon challenge\n" if DEBUG;
	} else {
		$kernel->yield('got_challenge', $socket);
	}
}

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

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

		print STDERR "got_challenge got the response \"$response\" for $socket\n" if DEBUG;
		if($response =~ /challenge +rcon +(\d+)/) {
			$heap->{jobs}->{$socket}->{challenge} = $1;
			$kernel->select_read($socket, 'got_rcon_response');
			send($socket, "\xFF\xFF\xFF\xFFrcon $1 \"" . $heap->{jobs}->{$socket}->{pw} . "\" " . $heap->{jobs}->{$socket}->{cmd} . "\0", 0);
			$heap->{jobs}->{$socket}->{timer} = $kernel->delay_set('rcon_timeout', $heap->{timeout}, $socket);
			print STDERR "Got rcon response and sent rcon command\n" if DEBUG;
		} else {
			$kernel->post($heap->{jobs}->{$socket}->{session}, $heap->{jobs}->{$socket}->{postback},
					$heap->{jobs}->{$socket}->{type}.
					$heap->{jobs}->{$socket}->{ip},
					$heap->{jobs}->{$socket}->{port},
					$heap->{jobs}->{$socket}->{cmd},
					$heap->{jobs}->{$socket}->{identifier},
					'ERROR: No challenge receieved from server.');
			delete($heap->{jobs}->{$socket});
		}
	} else {
		$kernel->select_read($socket, 'got_rcon_response');
		send($socket, "\xFF\xFF\xFF\xFFrcon \"" . $heap->{jobs}->{$socket}->{pw} . "\" " . $heap->{jobs}->{$socket}->{cmd} . "\0", 0);
		$heap->{jobs}->{$socket}->{timer} = $kernel->delay_set('rcon_timeout', $heap->{timeout}, $socket);
		print STDERR "Got socket and sent rcon command\n" if DEBUG;
	}
}

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

	$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 = '', $heap->{bytes}, 0);

	if($response =~ /bad (?:rconpassword|rcon_password)/i) {
		$kernel->post($heap->{jobs}->{$socket}->{session}, $heap->{jobs}->{$socket}->{postback},
				$heap->{jobs}->{$socket}->{type},
				$heap->{jobs}->{$socket}->{ip},
				$heap->{jobs}->{$socket}->{port},
				$heap->{jobs}->{$socket}->{cmd},
				$heap->{jobs}->{$socket}->{identifier},
				'ERROR: Bad Rcon password.');
	} else {
		# following regex's thanks to kkrcon
		$response =~ s/\x00+$//;	# terminator
		$response =~ s/^\xff\xff\xff\xffl//;	# new HL
		$response =~ s/^\xff\xff\xff\xffn//;	# qw
		$response =~ s/^\xff\xff\xff\xff//;	# q2/q3
		$response =~ s/^\xfe\xff\xff\xff.....//;	# old hl bug
		$kernel->post($heap->{jobs}->{$socket}->{session}, $heap->{jobs}->{$socket}->{postback},
				$heap->{jobs}->{$socket}->{type},
				$heap->{jobs}->{$socket}->{ip},
				$heap->{jobs}->{$socket}->{port},
				$heap->{jobs}->{$socket}->{cmd},
				$heap->{jobs}->{$socket}->{identifier},
				$response);
		print STDERR "Rcon Response was $response\n" if DEBUG;
	}
	delete($heap->{jobs}->{$socket});
}

sub challenge_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}->{type},
				$heap->{jobs}->{$socket}->{ip},
				$heap->{jobs}->{$socket}->{port},
				$heap->{jobs}->{$socket}->{cmd},
				$heap->{jobs}->{$socket}->{identifier},
				'ERROR: Timed out trying to obtain challenge.');
	} else {
		print STDERR "Challenge request timed out for $socket.  Retrying.\n" if DEBUG;
		send($socket, "\xFF\xFF\xFF\xFFchallenge rcon\n\0", 0);
		$heap->{jobs}->{$socket}->{timer} = $kernel->delay_set('challenge_timeout', $heap->{timeout}, $socket);
		$heap->{jobs}->{$socket}->{try}++;
	}
}

sub rcon_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}->{type},
				$heap->{jobs}->{$socket}->{ip},
				$heap->{jobs}->{$socket}->{port},
				$heap->{jobs}->{$socket}->{cmd},
				$heap->{jobs}->{$socket}->{identifier},
				'ERROR: Timed out waiting for Rcon response.');
	} else {
		print STDERR "Rcon timed out for $socket.  Retrying.\n" if DEBUG;
		send($socket, "\xFF\xFF\xFF\xFFrcon " . $heap->{jobs}->{$socket}->{challenge} . " \"" . $heap->{jobs}->{$socket}->{pw} . "\" " . $heap->{jobs}->{$socket}->{cmd} . "\0", 0) if $heap->{jobs}->{$socket}->{type} =~ /hl$/;
		send($socket, "\xFF\xFF\xFF\xFFrcon \"" . $heap->{jobs}->{$socket}->{pw} . "\" " . $heap->{jobs}->{$socket}->{cmd} . "\0", 0) if $heap->{jobs}->{$socket}->{type} =~ /^(?:q2|q3|qw)$/;
		$heap->{jobs}->{$socket}->{timer} = $kernel->delay_set('rcon_timeout', $heap->{timeout}, $socket);
		$heap->{jobs}->{$socket}->{try}++;
	}
}

sub players {
	my ($kernel, $heap, $sender, $type, $ip, $port, $password, $postback) = @_[KERNEL, HEAP, SENDER, ARG0..ARG4];
	my $identifier = defined($_[ARG5]) ? $_[ARG5] : undef;
	croak "IP address required to execute an Rcon command" unless defined $ip;
	croak "Port requred to execute an Rcon command" if !defined $port || $port !~ /^\d+$/;
	croak "Password requires to execute an Rcon command" if !defined $password || $password eq '';
	croak "Server type was not recognized" unless $type =~ /^(?:qw|q2|q3|oldhl|hl)$/;
	my $jobid = $playerSN;
	$playerSN++;
	print STDERR "Got a request for players at $ip:$port with jobid $jobid\n" if DEBUG;
	$kernel->yield('rcon', $type, $ip, $port, $password, 'status', 'player_response', $jobid);
	$heap->{p_jobs}->{$jobid} = {
		ip		=> $ip,
		port		=> $port,
		pw		=> $password,
		identifier	=> $identifier,
		session		=> $sender->ID(),
		postback	=> $postback,
		type		=> $type,
	};
}

sub player_response {
	my ($kernel, $heap, $jobid, $response) = @_[KERNEL, HEAP, ARG4, ARG5];
	print STDERR "Got a player request response for job $jobid\n" if DEBUG;
	if($response =~ /^ERROR\: /) {
		$kernel->post($heap->{p_jobs}->{$jobid}->{session},
			      $heap->{p_jobs}->{$jobid}->{postback},
			      $heap->{p_jobs}->{$jobid}->{type},
			      $heap->{p_jobs}->{$jobid}->{ip},
			      $heap->{p_jobs}->{$jobid}->{port},
			      $heap->{p_jobs}->{$jobid}->{identifier},
			      $response
			      );	# One of the errors generated from the rcon command...
	} else {
		if($heap->{p_jobs}->{$jobid}->{type} =~ /hl$/) {
			$kernel->yield('player_parse_hl', $jobid, $response);
		} elsif($heap->{p_jobs}->{$jobid}->{type} =~ /^(?:q2|q3|qw)$/) {
			$kernel->yield('player_parse_quake', $jobid, $response);
		}
	}
}

sub player_parse_hl {
	my ($kernel, $heap, $jobid, $response) = @_[KERNEL, HEAP, ARG0, ARG1];
	# This code is partially adapted from KKrcon
	my %players;
	foreach(split(/[\r\n]+/, $response)) {
		if(/^\#[\s\d]\d\s+
		     (?:\")(.+)(?:\")\s+	# Player name
		     (\d+)\s+		# Player ID
		     (\d+)\s+		# WonID
		     ([\d-]+)\s+	# Frag count
		     ([\d:]+)\s+	# time
		     (\d+)\s+		# ping
		     (\d+)\s+		# packetloss
		     (\S+)		# ip:port
		    $/x) {
			$players{$2} = {
				"Name"		=> $1,
				"UserID"	=> $2,
				"WonID"		=> $3,
				"Frags"		=> $4,
				"Time"		=> $5,
				"Ping"		=> $6,
				"Loss"		=> $7,
				"Address"	=> $8,
			};
		}
	}
	$kernel->post($heap->{p_jobs}->{$jobid}->{session},
		      $heap->{p_jobs}->{$jobid}->{postback},
		      $heap->{p_jobs}->{$jobid}->{type},
		      $heap->{p_jobs}->{$jobid}->{ip},
		      $heap->{p_jobs}->{$jobid}->{port},
		      $heap->{p_jobs}->{$jobid}->{identifier},
		      \%players
		      );
	delete($heap->{p_jobs}->{$jobid});
}

sub player_parse_quake {
	my ($kernel, $heap, $jobid, $response) = @_[KERNEL, HEAP, ARG0, ARG1];
	my %players;
	foreach(split(/[\r\n]+/, $response)) {
		if(/^\s*
		    (\d+)\s+		# num
		    ([\d-]+)\s+		# score
		    (\d+)\s+		# ping
		    (.+)		# name
		    \s+(\d+)\s+		# lastmsg
		    (\S+)\s+		# address
		    (\d+)		# qport
		    (?:\s+(\d+)|)	# rate
		   $/x) {
			$players{$1} = {
				"num"		=> $1,
				"score"		=> $2,
				"ping"		=> $3,
				"name"		=> $4,
				"lastmsg"	=> $5,
				"address"	=> $6,
				"qport"		=> $7,
			};
			if(defined($8) && $8 ne '') {
				$players{$1}{"rate"} = $8;
			}
		}
	}
	$kernel->post($heap->{p_jobs}->{$jobid}->{session},
			$heap->{p_jobs}->{$jobid}->{postback},
			$heap->{p_jobs}->{$jobid}->{type},
			$heap->{p_jobs}->{$jobid}->{ip},
			$heap->{p_jobs}->{$jobid}->{port},
			$heap->{p_jobs}->{$jobid}->{identifier},
			\%players
			);
	delete($heap->{p_jobs}->{$jobid});
}
1;

__END__