view release on metacpan or  search on metacpan

lib/MooX/Async/Console/TCP.pm  view on Meta::CPAN

before _remove_from_loop => sub {
  if ($_[0]->children) {
    $_[0]->_logger->warningf('TCP Console closed with %u active client[s]', scalar $_[0]->children);
    $_[0]->_detach_client($_) for $_[0]->children;
  }
};

=pod

C<_init>, which is used during the parent class
L<IO::Async::Listener>'s own construction, replaces its C<$args> with
a single entry of C<handle_constructor>.

=cut

around _init => sub {
  my $orig = shift;
  my $self = shift;

=pod

C<handle_constructor> contains a coderef to attach the client
implemented by L<MooX::Async::Console::TCPClient> and handle its
L<on_line> and L<on_close> events.

=cut

  my $line  = sub { unshift @_, $self; goto \&__on_line };
  my $close = sub { unshift @_, $self; goto \&__on_close};
  %{$_[0]} = (handle_constructor => sub {
    MooX::Async::Console::TCPClient->new(on_close => $close, on_line => $line);
  });
  $self->$orig(@_);
};

use namespace::clean '__close';
sub __on_close {
  my $self = shift;
  $self->invoke_event(on_terminate =>);
  $self->_logger->informf('Client disconnected from %s:%s', $_[0]->address, $_[0]->port);
  $self->_detach_client($_[0]);
}

=head3 Client's on_line event handler

For the present this is extremely simple. The client types in a line
of text and ends it with newline. That line is broken up into a list
on whitespace and the first word in the list is the command name, the
rest its args.

Only one command may be running at a time. This is enforced by the
C<$state> variable.

=cut

use namespace::clean '__line';
sub __on_line {
  my $self = shift;
  my $client = shift;
  my ($cmd, @args) = split ' ', shift;
  my $state;            # for now - false nothing, true busy;
  die 'One command at a time for now' if $state;
  $state++;
  my $quit;
  $self->_logger->debugf('Received command %s %s', $cmd, \@args);

=pod

The L</on_command> event handler is invoked with a new L<Future>.

=cut

  my $future = $self->loop->new_future;
  $self->adopt_future(
    $future->followed_by(sub {
      # Why is this useful?
      return Future->fail($_[0]->failure) if $_[0]->failure;
      my $command_future = $_[0]->get;
      return Future->done($command_future->get) if $command_future->is_done;

=pod

Disconnecting the client is treated specially so that everything is
shutdown in an orderly manner.

If the L<Future> which is given to the command handler is failed with
the word C<quit> then this is flagged using C<$quit> and the L<Future>
is replaced with a done L<Future> with an appropriate message
substituted.

=cut

      return Future->fail($command_future->failure) if $command_future->failure ne 'quit';
      $self->_logger->debugf('Requested disconnect');
      $quit = 1;
      return Future->done('disconnecting...');

=pod

After the L<Future> completes succesfully a message is returned to the
client containing its result.

=cut

    })->then(sub {
      my $r = $self->invoke_event(on_success => @_);
      @_ = $r->get if blessed $r and $r->DOES('Future');
      my $extra = @_ ? ' - ' . (join ' ', ('%s')x@_) : '';
      # TODO: Figure out a better way to do this
      $client->say(sprintf "OK$extra", Log::Any::Proxy::_stringify_params(@_));

=pod

If the C<$quit> flag is true the client is detached.

=cut

      if ($quit) {
        $self->_logger->informf('Client disconnecting from %s:%s', $client->address, $client->port);
        $self->_detach_client($client);
      }