#  You may distribute under the terms of either the GNU General Public License
#  or the Artistic License (the same terms as Perl itself)
#
#  (C) Paul Evans, 2020 -- leonerd@leonerd.org.uk

package Test::Future::IO;

use strict;
use warnings;

our $VERSION = '0.01';

=head1 NAME

C<Test::Future::IO> - unit testing on C<Future::IO>

=head1 SYNOPSIS

   use Test::More;
   use Test::Future::IO;

   my $controller = Test::Future::IO->controller;

   {
      $controller->expect_syswrite( "Hello, world\n" );
      $controller->expect_sysread( 256 )
         ->returns( "A string\n");

      code_under_test();

      $controller->check_and_clear( 'code under test did correct IO' );
   }

=head1 DESCRIPTION

This package provides a means to apply unit testing around code which uses
L<Future::IO>. It operates in an "expect-and-check" style of mocking,
requiring the test script to declare upfront what methods are expected to be
called, and what values they return.

=cut

=head1 EXPECTATIONS

Each of the actual C<Future::IO> methods has a corresponding expectation
method on the controller object, whose name is prefixed with C<expect_>. A
single call to one of these methods by the unit test script represents a
single call to a C<Future::IO> method that the code under test is expected to
make. The arguments to the expectation method should match those given by the
code under test. Each expectation method returns an object which has
additional methods to control the behaviour of that invocation.

   $exp = $controller->expect_sleep( $secs )

   $exp = $controller->expect_sysread( $len )
   $exp = $controller->expect_syswrite( $bytes )

Note that the C<sysread> and C<syswrite> expectations currently ignore the
filehandle argument.

The returned expectation object allows the test script to specify what such an
invocation should return.

   $exp->returns( @result )

=cut

my @expectations;

sub expect_sleep
{
   my $self = shift;
   my ( $secs ) = @_;

   return $expectations[@expectations] = Test::Future::IO::_Expectation->new(
      sleep => [ $secs ],
   );
}

sub expect_sysread
{
   my $self = shift;
   my ( $len ) = @_;

   return $expectations[@expectations] = Test::Future::IO::_Expectation->new(
      sysread => [ $len ],
   );
}

sub expect_syswrite
{
   my $self = shift;
   my ( $bytes ) = @_;

   return ($expectations[@expectations] = Test::Future::IO::_Expectation->new(
      syswrite => [ $bytes ],
   ))->returns( length $bytes );
}

=head1 METHODS

=cut

=head2 controller

   $controller = Test::Future::IO->controller;

Returns the control object, on which the various C<expect_*> methods and
C<check_and_clear> can be invoked.

=cut

sub controller { __PACKAGE__ }

=head2 check_and_clear

   $controller->check_and_clear( $name );

Checks that by now, every expected method has been called, and emits a new
test output line via L<Test::Builder>. Regardless, the expectations are also
cleared out ready for the start of the next test.

=cut

sub check_and_clear
{
   my $self = shift;
   my ( $name ) = @_;

   my $builder = Test::Builder->new;
   local $Test::Builder::Level = $Test::Builder::Level + 1;

   my $count = 0;
   foreach my $exp ( @expectations ) {
      $exp->_check( $builder );
      $count++;
   }

   $builder->ok( 1, "No calls made" ) if !$count;

   undef @expectations;
}

sub _stringify
{
   my ( $v ) = @_;
   if( $v =~ m/^-?[0-9]+$/ ) {
      return sprintf "%d", $v;
   }
   elsif( $v =~ m/^[\x20-\x7E]*\z/ ) {
      $v =~ s/([\\'])/\\$1/g;
      return qq('$v');
   }
   else {
      if( $v =~ m/^[^\n\x20-\x7E]/ ) {
         # string contains something non-printable; just hexdump it all
         $v =~ s{(.)}{sprintf "\\x%02X", ord $1}gse;
      }
      else {
         $v =~ s/([\\'\$\@])/\\$1/g;
         $v =~ s{\n}{\\n}g;
      }
      return qq("$v");
   }
}

sub _stringify_args
{
   join ", ", map { _stringify $_ } @_;
}

package
   Test::Future::IO::_Expectation;

use List::Util qw( all );

use constant {
   METHOD => 0,
   ARGS   => 1,
   RET_F  => 2,
   CALLED => 3,
};

sub new
{
   my $class = shift;
   my ( $method, $args ) = @_;
   return bless [ $method, $args, Future->new, 0 ], $class;
}

sub returns
{
   my $self = shift;

   $self->[RET_F]->done( @_ );
}

sub _consume
{
   my $self = shift;
   my ( $method, @args ) = @_;

   $method eq $self->[METHOD] or
      return 0;

   # TODO: something something Test::Deep
   all { $args[$_] eq $self->[ARGS][$_] } 0 .. $#args or
      return 0;

   $self->[CALLED]++;
   return 1;
}

sub _check
{
   my $self = shift;
   my ( $builder ) = @_;

   my $method = $self->[METHOD];
   $builder->ok( $self->[CALLED], "->$method(${\ Test::Future::IO::_stringify_args @{ $self->[ARGS] } })" );
}

sub _result
{
   my $self = shift;
   return $self->[RET_F];
}

sub _called
{
   my $self = shift;
   return $self->[CALLED];
}

package
   Test::Future::IO::_Impl;

use Carp;

use List::Util qw( first );

require Future::IO;
Future::IO->override_impl( __PACKAGE__ );

sub _call
{
   my ( $method, @args ) = @_;

   my $e;
   $e = first { !$_->_called } @expectations and
      $e->_consume( $method, @args ) or
      croak "Unexpected call to ->$method(${\ Test::Future::IO::_stringify_args @args })";

   return $e->_result;
}

sub sleep    { _call sleep => @_[1..$#_] }

# Ignore the filehandle arg
sub sysread  { _call sysread  => @_[2..$#_] }
sub syswrite { _call syswrite => @_[2..$#_] }

=head1 TODO

=over 4

=item *

Some L<Test::Deep> integration to be less fragile on things like sysread
length.

=item *

Configurable matching on filehandles. Provision of a mock filehandle object to
assist unit tests.

=item *

Ability for expectations to fail.

=back

=head1 AUTHOR

Paul Evans <leonerd@leonerd.org.uk>

=cut

0x55AA;
