File Coverage

blib/lib/POE/Component/OSCAR.pm

Criterion	Covered	Total	%
statement	22	33	66.6
branch			n/a
condition			n/a
subroutine	8	10	80.0
pod			n/a
total	30	43	69.7

package POE::Component::OSCAR;

use 5.006;
use strict;
use vars qw($VERSION);
use Filter::Template;
use POE 0.28;

$VERSION = .05;

# make life prettier
const KERNEL    $_[KERNEL]
const HEAP      $_[HEAP]
const SESSION   $_[SESSION]
const OBJECT    $_[OBJECT]
const ARGS      @_[ARG0..$#_]
const SENDER    $_[SENDER]

# Create an object skeleton to make code in the calling app prettier
sub new {
	my $class = shift;
	my @args = @_;

	my $self = {
		session => POE::Session->create(
			package_states => [
				OSCARSession => [qw(_start _stop _default queue_im rd_ok wr_ok ex_ok set_callback connection_changed quit)]
			],
			args => [ @args ],
		)
	};

	bless $self, $class;

	return $self;
}

# Pass $oscar->anymethod calls to the anymethod state of the POE
# session, which will get picked up by _default and passed to the
# Net::OSCAR object
sub AUTOLOAD {
	my $self = shift;

	use vars qw($AUTOLOAD);
	my $state = $AUTOLOAD;
	$state =~ s/.*:://;
	$poe_kernel->post( $self->{session} => $state => @_ );
}

package OSCARSession;

use POE;
use Net::OSCAR 0.62;
use Time::HiRes qw(sleep time);

# store filenos so if we get a new one, we can have POE watch it
my %filenos = ();

sub _start {
	my %args = ARGS;

	KERNEL->sig( INT => 'quit' );
	HEAP->{throttle_time} = delete $args{throttle};
	HEAP->{im_queue} = [];

	my $oscar = HEAP->{oscar} = Net::OSCAR->new( %args );
#	$oscar->loglevel( 10, 1 );

	$oscar->set_callback_connection_changed( SESSION->callback( 'connection_changed' ) );
}

sub rd_ok {
	my ($socket) = ARGS;
	my $fileno = fileno($socket);
	return unless $fileno;
	my $conn = HEAP->{oscar}->findconn($fileno);
	sleep 0.1;
	$conn->process_one(1, 0);
}

sub wr_ok {
	my ($socket) = ARGS;
	my $fileno = fileno($socket);
	return unless $fileno;
	my $conn = HEAP->{oscar}->findconn($fileno);
	sleep 0.1;
	$conn->process_one(0, 1);
}

sub ex_ok {
	my ($socket) = ARGS;
	my $fileno = fileno($socket);
	return unless $fileno;
	my $conn = HEAP->{oscar}->findconn($fileno);
	KERNEL->select($socket); # stop POE from watching the socket
	$conn->{sockerr} = 1;
	$conn->disconnect();
	sleep 0.1;
}

sub _stop {
}

sub queue_im {
	my @send_im_args = ARGS;

	my $queue = HEAP->{im_queue};
	if (@send_im_args) {
		push @$queue, \@send_im_args;
	}

	if (@$queue and HEAP->{last_im_sent_time} + HEAP->{throttle_time} < time) {
		my $args = shift @$queue;
		eval {
			HEAP->{oscar}->send_im( @$args );
		};
		warn $@ if $@;

		HEAP->{last_im_sent_time} = time;

	} else {
		KERNEL->delay( "queue_im",
			HEAP->{last_im_sent_time} + HEAP->{throttle_time} - time );
		return;
	}

	if (@$queue) {
		KERNEL->delay( "queue_im", HEAP->{throttle_time} );
	}
}

sub _default {
	my ($method, $args) = ARGS;

	if ($method eq 'send_im' and HEAP->{throttle_time}) {
		KERNEL->yield( "queue_im", @$args );
		return;
	}

	eval {
		HEAP->{oscar}->$method( @$args );
	};
	warn $@ if $@;
}

sub quit {
	exit;
}

sub set_callback {
	my ($callback, $state) = ARGS;

	my $method = "set_callback_${callback}";
	HEAP->{oscar}->$method( SENDER->postback( $state ) );
}

# Net::OSCAR will send us one of four states when a connection's
# state changes: read, write, readwrite, and deleted.  Unfortunately,
# "connected" is not one of these, so when we see anything other than
# a "deleted", we check %filenos to see if POE is already watching it.
# If not, we ask POE to watch it.
sub connection_changed {
	my @args = ARGS;
	my ($oscar_obj, $connection, $state) = @{$args[1]};

	my $socket = $connection->{socket};
	if ($state eq 'deleted') {
		delete $filenos{ fileno($socket) };
		$poe_kernel->select( $socket );
	} elsif (!$filenos{ fileno($socket) }) {
		# Need the line below for faster machines; otherwise some bits seem to get lost
		# along the way.  It's a hack, but it should only get called twice in all (once
		# upon connection, once upon signon) so for now it should suffice.
		sleep 0.1;
		$filenos{ fileno($socket) }++;
		$poe_kernel->select( $socket, 'rd_ok', 'wr_ok', 'ex_ok' );
	}
}

1;
__END__