File Coverage

blib/lib/AnyEvent/MockTCPServer.pm

Criterion	Covered	Total	%
statement	130	144	90.2
branch	9	16	56.2
condition	0	3	0.0
subroutine	28	31	90.3
pod	15	15	100.0
total	182	209	87.0

use strict;
use warnings;
package AnyEvent::MockTCPServer;
$AnyEvent::MockTCPServer::VERSION = '1.142230';
# ABSTRACT: Mock TCP Server using AnyEvent


1;

use constant {
  DEBUG => $ENV{ANYEVENT_MOCK_TCP_SERVER_DEBUG}
};
use AnyEvent;
use AnyEvent::Socket;
use AnyEvent::Handle;
use Test::More;
use Sub::Name;


sub new {
  my $pkg = shift;
  my $finished_cv = AnyEvent->condvar;
  my $self =
    {
     connections => [],
     listening => AnyEvent->condvar,
     finished_cv => $finished_cv,
     host => '127.0.0.1',
     port => undef,
     timeout => 2,
     on_timeout => subname('default_client_on_timeout_cb' =>
                           sub {
                             $finished_cv->end;
                             die "server timeout\n";
                           }),
     @_
    };
  bless $self, $pkg;

  foreach (@{$self->{connections}}) {
    $finished_cv->begin;
  }

  $self->{server} =
    tcp_server $self->{host}, $self->{port}, subname('accept_cb' =>
      sub {
        my ($fh) = @_;
        print STDERR "In server: $fh ", fileno($fh), "\n" if DEBUG;
        my $handle;
        $handle =
          AnyEvent::Handle->new(fh => $fh,
                                on_error => subname('client_on_error_cb_'.$fh =>
                                  sub {
                                    my ($hdl, $fatal, $msg) = @_;
                                    warn "error $msg\n";
                                    $self->{on_error}->(@_)
                                      if ($self->{on_error});
                                    $hdl->destroy;
                                  }),
                                timeout => $self->{timeout},
                                on_timeout => $self->{on_timeout},
                               );
      print STDERR "Connection handle: $handle\n" if DEBUG;
      $self->{handles}->{$handle} = $handle;
      my $con = $self->{connections};
      unless (@$con) {
        die "Server received unexpected connection\n";
      }
      my $actions = shift @$con;
      print STDERR "Actions: ", (scalar @$actions), "\n" if DEBUG;
      unless (@$con) {
        delete $self->{server};
      }
      $self->next_action($handle, $actions);
    }), subname('prepare_cb' => sub {
      my ($fh, $host, $port) = @_;
      die "tcp_server setup failed: $!\n" unless ($fh);
      $self->{listening}->send([$host, $port]);
      0;
    });
  return $self;
}

sub DESTROY {
  my $self = shift;
  delete $self->{listening};
  delete $self->{server};
  foreach (values %{$self->{handles}}) {
    next unless (defined $_);
    $_->destroy;
    delete $self->{handles}->{$_};
  }
}


sub listening {
  shift->{listening};
}


sub connect_address {
  @{shift->listening->recv};
}


sub connect_host {
  shift->listening->recv->[0];
}


sub connect_port {
  shift->listening->recv->[1];
}


sub connect_string {
  join ':', shift->connect_address
}


sub finished_cv {
  my $self = shift;
  $self->{finished_cv};
}


sub next_action {
  my ($self, $handle, $actions) = @_;
  print STDERR 'In handle connection ', scalar @$actions, "\n" if DEBUG;
  my $action = shift @$actions;
  unless (defined $action) {
    print STDERR "closing connection\n" if DEBUG;
    $handle->push_shutdown;
    delete $self->{handles}->{$handle};
    $self->{finished_cv}->end;
    return;
  }
  my $method = shift @$action;
  print STDERR "executing action: ", $method, "\n" if DEBUG;
  $self->$method($handle, $actions, @$action);
}


sub send {
  my ($self, $handle, $actions, $send, $desc) = @_;
  print STDERR 'Sending: ', $send, ' ', $desc, "\n" if DEBUG;
  print STDERR 'Sending ', length $send, " bytes\n" if DEBUG;
  $handle->push_write($send);
  $self->next_action($handle, $actions);
}


sub packsend {
  my ($self, $handle, $actions, $data, $desc) = @_;
  my $send = $data;
  $send =~ s/\s+//g;
  print STDERR 'Sending: ', $send, ' ', $desc, "\n" if DEBUG;
  $send = pack 'H*', $send;
  print STDERR 'Sending ', length $send, " bytes\n" if DEBUG;
  $handle->push_write($send);
  $self->next_action($handle, $actions);
}


sub recv {
  my ($self, $handle, $actions, $recv, $desc) = @_;
  print STDERR 'Waiting for ', $recv, ' ', $desc, "\n" if DEBUG;
  my $len = length $recv;
  print STDERR 'Waiting for ', $len, " bytes\n" if DEBUG;
  $handle->push_read(chunk => $len,
                     sub {
                       my ($hdl, $data) = @_;
                       print STDERR "In receive handler\n" if DEBUG;
                       is($data, $recv,
                          '... correct message received by server - '.$desc);
                       $self->next_action($hdl, $actions);
                       1;
                     });
}


sub recvline {
  my ($self, $handle, $actions, $recv, $desc) = @_;
  print STDERR 'Waiting for ', $recv, ' ', $desc, "\n" if DEBUG;
  print STDERR "Waiting for line\n" if DEBUG;
  $handle->push_read(line =>
                     sub {
                       my ($hdl, $data) = @_;
                       print STDERR "In receive handler\n" if DEBUG;
                       $recv = $recv->() if (ref $recv && ref $recv eq 'CODE');
                       if (ref $recv) {
                         like($data, $recv,
                            '... correct message received by server - '.$desc);
                       } else {
                         is($data, $recv,
                            '... correct message received by server - '.$desc);
                       }
                       $self->next_action($hdl, $actions);
                       1;
                     });
}


sub packrecv {
  my ($self, $handle, $actions, $data, $desc) = @_;
  my $recv = $data;
  $recv =~ s/\s+//g;
  my $expect = $recv;
  print STDERR 'Waiting for ', $recv, ' ', $desc, "\n" if DEBUG;
  my $len = .5*length $recv;
  print STDERR 'Waiting for ', $len, " bytes\n" if DEBUG;
  $handle->push_read(chunk => $len,
                     sub {
                       my ($hdl, $data) = @_;
                       print STDERR "In receive handler\n" if DEBUG;
                       my $got = uc unpack 'H*', $data;
                       is($got, $expect,
                          '... correct message received by server - '.$desc);
                       $self->next_action($hdl, $actions);
                       1;
                     });
}


sub sleep {
  my ($self, $handle, $actions, $interval, $desc) = @_;
  print STDERR 'Sleeping for ', $interval, ' ', $desc, "\n" if DEBUG;
  my $w;
  $w = AnyEvent->timer(after => $interval,
                       cb => sub {
                         $self->next_action($handle, $actions);
                         undef $w;
                       });
}


sub code {
  my ($self, $handle, $actions, $code, $desc) = @_;
  print STDERR 'Executing ', $code, ' for ', $desc, "\n" if DEBUG;
  $code->($self, $handle, $desc);
  $self->next_action($handle, $actions);
}

1;

__END__