File Coverage

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

Criterion	Covered	Total	%
statement	27	177	15.2
branch	0	72	0.0
condition	0	11	0.0
subroutine	9	25	36.0
pod	4	12	33.3
total	40	297	13.4

package POE::Component::Client::Telnet;

use POE 0.31;
use POE::Wheel::Run;
use POE::Filter::Line;
use POE::Filter::Reference;
use Net::Telnet;
use Carp qw(carp croak);
use Devel::Symdump;
use vars qw($AUTOLOAD);

use strict;

our $VERSION = '0.06';

sub AUTOLOAD {
	my $self = shift;
	my $method = $AUTOLOAD;
	$method =~ s/.*:://;
	return unless $method =~ /[^A-Z]/;

	warn "autoload method $method" if ($self->{debug});

	my $hash = shift;
	croak 'first param must be a hash ref of options' unless (ref($hash) eq 'HASH');

	$hash->{wantarray} = wantarray() unless (defined($hash->{wantarray}));
	$poe_kernel->post($self->session_id() => $method => $hash => @_);
}

sub spawn {
	goto &new;
}

sub new {
	my $package = shift;
	croak "$package needs an even number of parameters" if @_ & 1;
	my %params = @_;

	foreach my $param ( keys %params ) {
		$params{ lc $param } = delete ( $params{ $param } );
	}

	my $options = delete ( $params{'options'} );
	$params{package} ||= 'Net::Telnet';

	# map of commands to packages
	$params{cmd_map} = {};

	my $self = bless(\%params, $package);

	if ($params{package} ne 'Net::Telnet') {
		eval "use $params{package}";
		die $@ if ($@);
	}

	my @obj = Devel::Symdump->functions('Net::Telnet');
	push(@obj,Devel::Symdump->functions($params{package}));

	foreach my $p (@obj) {
		my ($pk,$sub) = ($p =~ m/^(.+)\:\:([^\:]+)/);

		next unless ($sub =~ /[^A-Z_0-9]$/);
		next if ($sub =~ m/^_/ || $sub =~ m/(carp|croak|confess)$/);
		my $o = $p;

		if (defined &$o) {
			$self->{cmd_map}->{$sub} = $pk;
		}
	}

	$self->{session_id} = POE::Session->create(
		object_states => [
			$self => { (map { $_ => 'request' } keys %{$self->{cmd_map}}) },
			$self => [ qw(_start shutdown wheel_close wheel_err wheel_out wheel_stderr) ],
		],
		( ( defined ( $options ) and ref ( $options ) eq 'HASH' ) ? ( options => $options ) : () ),
	)->ID();

	warn "session $self->{session_id} created for $params{package}" if ($self->{debug});

	return $self;
}

# POE related object methods

sub _start {
	my ($kernel,$self) = @_[KERNEL,OBJECT];

	if ( $self->{alias} ) {
		$kernel->alias_set( $self->{alias} );
	} else {
		$kernel->refcount_increment( $self->{session_id} => __PACKAGE__ );
	}

	$self->{wheel} = POE::Wheel::Run->new(
		Program      => \&process_requests,
		CloseOnCall  => 0,
		StdinFilter  => POE::Filter::Reference->new(),
		StdoutFilter => POE::Filter::Reference->new(),
		StderrFilter => POE::Filter::Line->new(),
		StdoutEvent  => 'wheel_out',
		StderrEvent  => 'wheel_stderr',
		ErrorEvent   => 'wheel_err',
		CloseEvent   => 'wheel_close',
	);

	# adjust options
	if ($self->{package} ne 'Net::Telnet') {
		$self->{telnet_options} = [ (@{$self->{telnet_options}}, '_Package' => $self->{package}) ];
	}

	if ($self->{telnet_options} && ref($self->{telnet_options}) eq 'ARRAY') {
		$self->{wheel}->put($self->{telnet_options});
	}

	undef;
}

sub request {
	my ($kernel,$self,$state,$sender) = (@_[KERNEL,OBJECT,STATE],$_[SENDER]->ID);

	warn "processing request $state\n" if ($self->{debug});
	# Get the arguments
	my $args;
	if (ref($_[ARG0]) eq 'HASH') {
		$args = { %{ $_[ARG0] } };
	} else {
		warn "first parameter must be a ref hash, trying to adjust. "
			."(fix this to get rid of this message)";
		$args = { @_[ARG0 .. $#_ ] };
	}

	if ($self->{wheel}) {
		$args->{session} = $sender;
		$args->{func} = $state;
		$args->{state} = $state;
		$args->{args} = [ @_[ ARG1 .. $#_ ] ];

		# if we have an event to report to...make sure we stay around
		if ($args->{event}) {
			$kernel->refcount_increment($sender => __PACKAGE__);
		}

		$self->{wheel}->put($args);
	}

	undef;
}

sub wheel_out {
	my ($kernel,$self,$input) = @_[KERNEL,OBJECT,ARG0];

	delete $input->{func};

	my $session = delete $input->{session};
	my $event = delete $input->{event};

	if ($event) {
		$kernel->post($session => $event => $input);
		$kernel->refcount_decrement($session => __PACKAGE__);
	}

	undef;
}

sub wheel_stderr {
	my ($kernel,$self,$input) = @_[KERNEL,OBJECT,ARG0];

	warn "$input\n" if ($self->{debug});
}

sub wheel_err {
    my ($self, $operation, $errnum, $errstr, $wheel_id) = @_[OBJECT, ARG0..ARG3];

    warn "Wheel $wheel_id generated $operation error $errnum: $errstr\n" if ($self->{debug});
}

sub wheel_close {
	my $self = $_[OBJECT];

	warn "Wheel closed\n" if ($self->{debug});

	warn "$self->{package} Wheel closed, ieeeeeeee!\n";
}

# Dual event and object methods

sub shutdown {
	unless (UNIVERSAL::isa($_[KERNEL],'POE::Kernel')) {
		if ($poe_kernel) {
			$poe_kernel->call(shift->session_id() => 'shutdown' => @_);
		}
		return;
	}

	my ($kernel,$self) = @_[KERNEL,OBJECT];

	# remove alias or decrease ref count
	if ($self->{alias}) {
		$kernel->alias_remove($_) for $kernel->alias_list();
	} else {
		$kernel->refcount_decrement($self->session_id() => __PACKAGE__);
	}

	if ($self->{wheel}) {
		$self->{wheel}->shutdown_stdin;
	}
	undef;
}


# Object methods

sub session_id {
	shift->{session_id};
}

sub yield {
	my $self = shift;
	$poe_kernel->post($self->session_id() => @_);
}

sub call {
	my $self = shift;
	$poe_kernel->call($self->session_id() => @_);
}

sub DESTROY {
	if (UNIVERSAL::isa($_[0],__PACKAGE__)) {
		$_[0]->shutdown();
	}
}

# Main Wheel::Run process sub

sub process_requests {
	binmode(STDIN);
	binmode(STDOUT);

	my $raw;
	my $size = 4096;
	my $filter = POE::Filter::Reference->new();

	# telnet object
	my $t;

	# there's room for other callbacks
	my %callbacks = (
		option_callback => undef,
	);

	READ:
	while ( sysread ( STDIN, $raw, $size ) ) {
		my $requests = $filter->get([$raw]);

		unless ($t) {
			my $arg = shift(@{$requests});
			if (ref($arg) eq 'ARRAY') {
				my $package = 'Net::Telnet';
				my %args = ( @$arg );
				if ($args{_Package}) {
					$package = delete $args{'_Package'};
					eval "use $package";
					if ($@) {
						die "$@\n";
					}
				}
				$t = $package->new(%args);
			} else {
				$t = Net::Telnet->new();
				unshift(@{$requests},$arg);
			}
		}

    	foreach my $req (@{$requests}) {
			my $func = $req->{func};

			if ($func eq 'option_callback') {
				if (@{$req->{args}}) {
					# set the callback event
					$callbacks{$func} = $req->{args}->[0];
					# TODO allow unsetting event?   Net::Telnet doesn't allow it...
					# then set a coderef to post that back
					$t->$func(sub {
						# $obj, $option, $is_remote, $is_enabled, $was_enabled, $buf_position
						shift; # don't need and can't send the object
						$req->{result} = [ @_ ];
						$req->{event} = $callbacks{$func};
						my $rep = $filter->put( [ $req ] );
						print STDOUT @$rep;
					});
				} else {
					$req->{result} = $callbacks{$func};
					my $rep = $filter->put( [ $req ] );
					print STDOUT @$rep;
				}
				next;
			}

			my @result;
			eval {
				@result = $t->$func(@{$req->{args}});
			};
			if ($@) {
				$req->{error} = $@;
				@result = undef;
			}

			if ($req->{wantarray}) {
				$req->{result} = \@result;
			} else {
				$req->{result} = $result[0];
			}

			my $replies = $filter->put( [ $req ] );
			print STDOUT @$replies;
		}
	}
}

1;

__END__