AnyEvent-Finger

 view release on metacpan or  search on metacpan

Changes  view on Meta::CPAN

0.06      2013-03-20 17:48:44 America/New_York
  - documentation updates

0.05      2013-02-09 18:46:53 America/New_York
  - documentation tweaks

0.04      2013-02-09 17:00:20 America/New_York
  - minor inheritence tweak

0.03      2013-02-09 09:22:11 America/New_York
  - pass $server object into on_bind first argument

0.02      2013-02-09 09:13:27 America/New_York
  - create on_bind callback on server for when port # is not known in advance
  - don't use Condvar#recv from AnyEvent::Finger::Server as it may not be
    supported by the AnyEvent implementation

0.01      2013-01-22 10:50:03 America/New_York
  - initial version

author.yml  view on Meta::CPAN

---
pod_spelling_system:
  stopwords:
    - hostname
    - hostnames
    - TCP
    - IP
    - bindport
    - req
    - PlugAuth

pod_coverage:
  private:
    - AnyEvent::Finger.*#new

example/server.pl  view on Meta::CPAN

#!/usr/bin/perl

use strict;
use warnings;
use AnyEvent::Finger::Server;

# bind to 79 if root, otherwise use
# an unprivilaged port
my $port = ($> && $^O !~ /^(cygwin|MSWin32)$/) ? 8079 : 79;

print "listening to port $port\n";

my $server = AnyEvent::Finger::Server->new( port => $port );

$server->start(
  sub {
    my $tx = shift;

lib/AnyEvent/Finger.pm  view on Meta::CPAN

  my($hostname) = shift;
  require AnyEvent::Finger::Client;
  AnyEvent::Finger::Client
    ->new( hostname => $hostname )
    ->finger(@_);
  ();
}


# keep the server object in scope so that
# we don't unbind from the port.  If you
# don't want this, then use the OO interface
# for ::Server instead.
my $keep = [];

sub finger_server ($;$)
{
  require AnyEvent::Finger::Server;
  my $server = AnyEvent::Finger::Server
    ->new
    ->start(@_);

lib/AnyEvent/Finger/Server.pm  view on Meta::CPAN

  my $port = $args->{port};
  $port = 79 unless defined $port;
  my $forward_deny = $args->{forward_deny};
  $forward_deny = 0 unless defined $forward_deny;
  my $forward = $args->{forward};
  $forward = 0 unless defined $forward;
  bless {
    hostname     => $args->{hostname},
    port         => $port,
    on_error     => $args->{on_error}     || sub { carp $_[0] },
    on_bind      => $args->{on_bind}      || sub { },
    forward_deny => $forward_deny,
    forward      => $forward,
  }, $class;
}


sub start
{
  my $self     = shift;
  my $callback = shift;
  my $args     = ref $_[0] eq 'HASH' ? (\%{$_[0]}) : ({@_});

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

  for(qw( hostname port on_error on_bind forward forward_deny ))
  {
    next if defined $args->{$_};
    $args->{$_} = $self->{$_};
  }


  my $forward = $args->{forward};
  $forward = $self->{forward} unless defined $forward;
  if($forward)
  {

lib/AnyEvent/Finger/Server.pm  view on Meta::CPAN

        }
      };

      bless $res, 'AnyEvent::Finger::Response';
      my $req = AnyEvent::Finger::Request->new($line);

      my $tx = bless {
        req            => $req,
        res            => $res,
        remote_port    => $port,
        local_port     => $self->{bindport},
        remote_address => $host,
      }, 'AnyEvent::Finger::Transaction';

      if($args->{forward_deny} && $tx->req->forward_request)
      {
        $res->(['finger forwarding service denied', undef]);
        return;
      }

      if($forward && $req->forward_request)

lib/AnyEvent/Finger/Server.pm  view on Meta::CPAN

      $callback->($tx);
    });
  };

  my $port = $args->{port};
  undef $port if $port == 0;

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

  $self;
}


sub bindport { shift->{bindport} }


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

1;

__END__

=pod

=encoding UTF-8

lib/AnyEvent/Finger/Server.pm  view on Meta::CPAN

=item *

on_error (carp error)

A callback subref to be called on error (either connection or transmission error).
Passes the error string as the first argument to the callback.

=item *

on_bind

A callback subref to be called when the port number is known.  This is
useful when ephemeral port is used but other parts of the code depend on it.
The first argument to the callback will be the L<AnyEvent::Finger::Server>
object.

=item *

forward_deny (0)

lib/AnyEvent/Finger/Server.pm  view on Meta::CPAN

asynchronously).

 # $dbh is a DBI database handle
 my $sth = $dbh->prepare("select user_name from user_list");
 while(my $h = $sth->fetchrow_hashref)
 {
   $tx->res->say($h->{user_name});
 }
 $tx->res->done;

The server will unbind from its port and stop if the server
object falls out of scope, or if the C<stop> method (see below)
is called.

=head2 bindport

 $server->bindport

The bind port.  If port is set to zero in the constructor or on
start, then an ephemeral port will be used, and you can get the
port number here.  This value is not available until the socket
has been allocated and bound to a port, so if you need this
value after calling C<start> but before any clients have connected
use the C<on_bind> callback.

=head2 stop

 $server->stop

Stop the server and unbind to the port.

=head1 SEE ALSO

=over 4

=item

L<AnyEvent::Finger>

=item

t/forward.t  view on Meta::CPAN

use strict;
use warnings;
use Test::More tests => 8;
use AnyEvent::Finger::Client;
use AnyEvent::Finger::Server;

my $bind = AnyEvent->condvar;

my $server1 = AnyEvent::Finger::Server->new(
  port         => 0,
  hostname     => '127.0.0.1',
  forward_deny => 1,
  on_bind      => sub { $bind->send },
);

$server1->start(sub {
  my $tx = shift;
  $tx->res->say('server1');
  $tx->res->say('username = ' . $tx->req->username);
  $tx->res->say('verbose  = ' . $tx->req->verbose);
  $tx->res->done;
});

$bind->recv;
like $server1->bindport, qr{^[1-9]\d*$}, "server1->bindport = " . $server1->bindport;

my $client1 = AnyEvent::Finger::Client->new(
  port     => $server1->bindport,
  on_error => sub { say STDERR shift; exit 2 },
);

$bind = AnyEvent->condvar;
my $server2 = AnyEvent::Finger::Server->new(
  port     => 0,
  hostname => '127.0.0.1',
  forward  => $client1,
  on_bind  => sub { $bind->send },
);
$server2->start(sub {
  my $tx = shift;
  $tx->res->say('server2');
  $tx->res->done;
});

like $server2->bindport, qr{^[1-9]\d*$}, "server2->bindport = " . $server2->bindport;

my $client2 = AnyEvent::Finger::Client->new(
  port     => $server2->bindport,
  on_error => sub { say STDERR shift; exit 2 },
);

subtest 'finger', sub {
  my $done = AnyEvent->condvar;

  my $lines;
  $client2->finger('', sub {
    ($lines) = shift;
    $done->send;

t/forward_deny.t  view on Meta::CPAN

use strict;
use warnings;
use Test::More tests => 6;
use AnyEvent::Finger::Client;
use AnyEvent::Finger::Server;

my $bind = AnyEvent->condvar;
my $server = eval {
  AnyEvent::Finger::Server->new(
    port         => 0,
    hostname     => '127.0.0.1',
    forward_deny => 1,
    on_bind      => sub { $bind->send },
  );
};
diag $@ if $@;
isa_ok $server, 'AnyEvent::Finger::Server';

eval { $server->start(
  sub {
    my $tx = shift;
    $tx->res->say("okay");
    $tx->res->done;
  }
) };
diag $@ if $@;

$bind->recv;
my $port = $server->bindport;
like $port, qr{^[123456789]\d*$}, "bindport = $port";

my $client = AnyEvent::Finger::Client->new( port => $port, on_error => sub { say STDERR shift; exit 2 } );

subtest "finger" => sub {
  my $done = AnyEvent->condvar;

  my $lines;
  $client->finger('', sub {
    ($lines) = shift;
    $done->send;

t/server.t  view on Meta::CPAN

use strict;
use warnings;
use Test::More tests => 6;
use AnyEvent::Finger::Client;
use AnyEvent::Finger::Server;

my $bind;

my $server = eval {
  AnyEvent::Finger::Server->new(
    port     => 0,
    hostname => '127.0.0.1',
    on_bind  => sub { $bind->send },
  );
};
diag $@ if $@;
isa_ok $server, 'AnyEvent::Finger::Server';

eval {
  $bind = AnyEvent->condvar;
  $server->start(
    sub {
      my $tx = shift;
      my $req = $tx->req;
      eval {
        $tx->res->say("request = '$req'");
        $tx->res->say($tx->remote_port);
        $tx->res->say($tx->local_port);
        $tx->res->say($tx->remote_address);
      };
      diag $@ if $@;
      $tx->res->done;
    }
  );
  $bind->recv;
};
diag $@ if $@;

my $port = $server->bindport;
like $port, qr{^[123456789]\d*$}, "bindport = $port";

my $client = AnyEvent::Finger::Client->new( port => $port, on_error => sub { say STDERR shift; exit 2 } );

subtest t1 => sub {
  my $done = AnyEvent->condvar;

  my $lines;
  $client->finger('', sub {
    ($lines) = shift;
    $done->send;

t/server.t  view on Meta::CPAN

    $done->send;
  });

  $done->recv;

  is $lines->[0], "request = 'grimlock'", 'response is correct';
};

eval {
  $server->stop;
  $bind = AnyEvent->condvar;
  $server->start(sub {
    my $tx = shift;
    $tx->res->say(
      "request_isa: " . ref($tx->req),
      "verbose:     " . $tx->req->verbose,
      "username:    " . $tx->req->username,
      "hostnames:   " . join("@", @{ $tx->req->hostnames }),
    );
    $tx->res->done;
  });
  $bind->recv;
};
diag $@ if $@;

$port = $server->bindport;
like $port, qr{^[123456789]\d*$}, "bindport = $port";
$client = AnyEvent::Finger::Client->new( port => $port, on_error => sub { say STDERR shift; exit 2 } );

subtest t3 => sub {
  my $done = AnyEvent->condvar;

  my $lines;
  $client->finger('/W grimlock@localhost@foo@bar@baz', sub {
    $lines = shift;
    $done->send;
  });

t/simple.t  view on Meta::CPAN

use Test::More tests => 3;
use AnyEvent;
use AnyEvent::Finger qw( finger_server finger_client );

our $timeout = AnyEvent->timer(
  after => 15,
  cb    => sub { diag "TIMEOUT"; exit },
);

my $port = eval {
  my $bind = AnyEvent->condvar;
  my $server = finger_server sub {
    my $tx = shift;
    my $req = $tx->req;
    $tx->res->([
      "request = '$req'",
      undef,
    ]);
  }, { port => 0, hostname => '127.0.0.1', on_bind => sub { $bind->send } };
  $bind->recv;
  $server->bindport;
};
diag $@ if $@;

like $port, qr{^[123456789]\d*$}, "bindport = $port";

my $error = sub { diag shift; exit 2 };

subtest t1 => sub {
  my $done = AnyEvent->condvar;

  my $lines;
  finger_client '127.0.0.1', '', sub {
    ($lines) = shift;
    $done->send;