File Coverage

blib/lib/AnyEvent/Ident/Server.pm

Criterion	Covered	Total	%
statement	59	65	90.7
branch	5	8	62.5
condition	2	4	50.0
subroutine	15	17	88.2
pod	3	4	75.0
total	84	98	85.7

package AnyEvent::Ident::Server;

use strict;
use warnings;
use AnyEvent;
use AnyEvent::Socket qw( tcp_server );
use AnyEvent::Handle;
use AnyEvent::Ident::Request;
use AnyEvent::Ident::Response;
use AnyEvent::Ident::Transaction;
use Carp qw( croak carp );

# ABSTRACT: Simple asynchronous ident server
our $VERSION = '0.08'; # VERSION


sub new
{
  my $class = shift;
  my $args  = ref $_[0] eq 'HASH' ? (\%{$_[0]}) : ({@_});
  my $port  = $args->{port};
  $port = 113 unless defined $port;
  bless {
    hostname => $args->{hostname},
    port     => $port,
    on_error => $args->{on_error} || sub { carp $_[0] },
    on_bind  => $args->{on_bind}  || sub { },
  }, $class;
}


sub start
{
  my($self, $callback) = @_;

  croak "already started" if $self->{guard};

  my $cb = sub {
    my ($fh, $host, $port) = @_;

    my $handle;
    $handle = AnyEvent::Handle->new(
      fh       => $fh,
      on_error => sub {
        my ($hdl, $fatal, $msg) = @_;
        $self->{on_error}->($msg);
        $_[0]->destroy;
      },
      on_eof   => sub {
        $handle->destroy;
      },
    );

    $handle->on_read(sub {
      $handle->push_read( line => sub {
        my($handle, $line) = @_;
        $line =~ s/\015?\012//g;
        my $req = eval { AnyEvent::Ident::Request->new($line) };
        return $handle->push_write("$line:ERROR:INVALID-PORT\015\012") if $@;
        my $tx = bless {
          req            => $req,
          remote_port    => $port,
          local_port     => $self->{bindport},
          remote_address => $host,
          cb             => sub {
            my($res) = @_;
            $handle->push_write($res->as_string . "\015\012");
          },
        }, 'AnyEvent::Ident::Transaction';
        $callback->($tx);
      })
    });
  };

  $self->{guard} = tcp_server $self->{hostname}, $self->{port}, $cb, sub {
    my($fh, $host, $port) = @_;
    $self->{bindport} = $port;
    $self->{on_bind}->($self);
  };

  $self;
}


sub bindport { shift->{bindport} }


sub stop
{
  my($self) = @_;
  delete $self->{guard};
  delete $self->{bindport};
  $self;
}

1;

__END__