File Coverage

blib/lib/POE/Component/Server/Echo.pm

Criterion	Covered	Total	%
statement	84	87	96.5
branch	18	36	50.0
condition	5	15	33.3
subroutine	18	19	94.7
pod	3	3	100.0
total	128	160	80.0

# $Id: Echo.pm,v 1.3 2005/01/27 08:37:22 chris Exp $
#
# POE::Component::Server::Echo, by Chris 'BinGOs' Williams
#
# This module may be used, modified, and distributed under the same
# terms as Perl itself. Please see the license that came with your Perl
# distribution for details.
#

package POE::Component::Server::Echo;
$POE::Component::Server::Echo::VERSION = '1.66';
#ABSTRACT: A POE component that implements an RFC 862 Echo server.

use strict;
use warnings;
use POE qw( Wheel::SocketFactory Wheel::ReadWrite Driver::SysRW
            Filter::Line );
use Carp;
use Socket;
use IO::Socket::INET;

use constant DATAGRAM_MAXLEN => 1024;
use constant DEFAULT_PORT => 7;

sub spawn {
  my $package = shift;
  croak "$package requires an even number of parameters" if @_ & 1;

  my %parms = @_;

  $parms{'Alias'} = 'Echo-Server' unless defined $parms{'Alias'} and $parms{'Alias'};
  $parms{'tcp'} = 1 unless defined $parms{'tcp'} and $parms{'tcp'} == 0;
  $parms{'udp'} = 1 unless defined $parms{'udp'} and $parms{'udp'} == 0;

  my $self = bless( { }, $package );

  $self->{CONFIG} = \%parms;

  POE::Session->create(
	object_states => [
		$self => { _start => '_server_start',
			   _stop  => '_server_stop',
			   shutdown => '_server_close' },
		$self => [ qw(_accept_new_client _accept_failed _client_input _client_error _get_datagram) ],
			  ],
	( ref $parms{'options'} eq 'HASH' ? ( options => $parms{'options'} ) : () ),
  );

  return $self;
}

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

  $kernel->alias_set( $self->{CONFIG}->{Alias} );

  if ( $self->{CONFIG}->{tcp} ) {
    $self->{Listener} = POE::Wheel::SocketFactory->new(
      ( defined ( $self->{CONFIG}->{BindAddress} ) ? ( BindAddress => $self->{CONFIG}->{BindAddress} ) : () ),
      ( defined ( $self->{CONFIG}->{BindPort} ) ? ( BindPort => $self->{CONFIG}->{BindPort} ) : ( BindPort => DEFAULT_PORT ) ),
      SuccessEvent   => '_accept_new_client',
      FailureEvent   => '_accept_failed',
      SocketDomain   => AF_INET,             # Sets the socket() domain
      SocketType     => SOCK_STREAM,         # Sets the socket() type
      SocketProtocol => 'tcp',               # Sets the socket() protocol
      Reuse          => 'on',                # Lets the port be reused
    );
  }
  if ( $self->{CONFIG}->{udp} ) {
    my $proto = getprotobyname('udp');
    my $port = defined ( $self->{CONFIG}->{BindPort} ) ? $self->{CONFIG}->{BindPort} : DEFAULT_PORT;
    my $paddr = sockaddr_in($port, INADDR_ANY);
    socket( my $socket, PF_INET, SOCK_DGRAM, $proto)   || die "socket: $!";
    bind( $socket, $paddr)                          || die "bind: $!";
    $self->{udp_socket} = $socket;
    $kernel->select_read( $self->{udp_socket}, "_get_datagram" );
  }
  undef;
}

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

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

  delete $self->{Listener};
  delete $self->{Clients};
  $kernel->select( $self->{udp_socket} );
  delete $self->{udp_socket};
  $kernel->alias_remove( $self->{CONFIG}->{Alias} );
  undef;
}

sub _accept_new_client {
  my ($kernel,$self,$socket,$peeraddr,$peerport) = @_[KERNEL,OBJECT,ARG0 .. ARG2];
  $peeraddr = inet_ntoa($peeraddr);

  my $wheel = POE::Wheel::ReadWrite->new (
        Handle => $socket,
        Filter => POE::Filter::Line->new(),
        InputEvent => '_client_input',
        ErrorEvent => '_client_error',
  );

  my $wheel_id = $wheel->ID();
  $self->{Clients}->{ $wheel_id }->{Wheel} = $wheel;
  $self->{Clients}->{ $wheel_id }->{peeraddr} = $peeraddr;
  $self->{Clients}->{ $wheel_id }->{peerport} = $peerport;
  undef;
}

sub _accept_failed {
  my ($kernel,$self) = @_[KERNEL,OBJECT];
  $kernel->yield( 'shutdown' );
  undef;
}

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

  if ( defined ( $self->{Clients}->{ $wheel_id } ) and defined ( $self->{Clients}->{ $wheel_id }->{Wheel} ) ) {
	$self->{Clients}->{ $wheel_id }->{Wheel}->put($input);
  }
  undef;
}

sub _client_error {
  my ($self,$wheel_id) = @_[OBJECT,ARG3];
  delete $self->{Clients}->{ $wheel_id };
  undef;
}

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

  my $remote_address = recv( $socket, my $message = "", DATAGRAM_MAXLEN, 0 );
    return unless defined $remote_address;

  send( $socket, $message, 0, $remote_address ) == length($message)
      or warn "Trouble sending response: $!";
  undef;
}

sub sockname_tcp {
  my $self = shift;
  my $name;
  $name =  $self->{Listener}->getsockname() if $self->{CONFIG}->{tcp};
  return unless $name;
  return sockaddr_in($name);
}

sub sockname_udp {
  my $self = shift;
  return unless $self->{CONFIG}->{udp} and $self->{udp_socket};
  return sockaddr_in( getsockname $self->{udp_socket} );
}

qq[ECHO! ECHO...ECHO...ECHO...ECHO...ECHO...ECHO...ECHo...ECho...Echo...echo];

__END__