view release on metacpan or  search on metacpan

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

  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__

=pod

=head1 NAME

AnyEvent::MockTCPServer - Mock TCP Server using AnyEvent

=head1 VERSION

version 1.172150

=head1 SYNOPSIS

  use AnyEvent::MockTCPServer qw/:all/;
  my $cv = AnyEvent->condvar;
  my $server =
    AnyEvent::MockTCPServer->new(connections =>
                                 [
                                  [ # first connection
                                   [ recv => 'HELLO', 'wait for "HELLO"' ],
                                   [ sleep => 0.1, 'wait 0.1s' ],
                                   [ code => sub { $cv->send('done') },
                                     'send "done" with condvar' ],
                                   [ send => 'BYE', 'send "BYE"' ],
                                   # ...
                                  ],
                                  [ # second connection
                                   # ...
                                  ]],
                                 # ...
                                );

=head1 DESCRIPTION

This module provides a TCP server with a set of defined behaviours for
use in testing of TCP clients.  It is intended to be use when testing
AnyEvent TCP client interfaces.

=head1 METHODS

=head2 C<new(%parameters)>

Constructs a new L<AnyEvent::MockTCPServer> object.  The parameter hash