File Coverage

blib/lib/Test/AnyEventFTPServer.pm

Criterion	Covered	Total	%
statement	222	268	82.8
branch	32	64	50.0
condition	27	59	45.7
subroutine	29	35	82.8
pod	12	12	100.0
total	322	438	73.5

package Test::AnyEventFTPServer;

use strict;
use warnings;
use 5.010;
use Moo;
use URI;
use AnyEvent;
use Test2::API qw( context );
use Path::Class qw( tempdir );

extends 'AnyEvent::FTP::Server';

# ABSTRACT: Test (non-blocking) ftp clients against a real FTP server
our $VERSION = '0.17'; # VERSION


has test_uri => (
  is       => 'ro',
  required => 1,
);


has res => (
  is => 'rw',
);


has content => (
  is      => 'rw',
  default => '',
);


has auto_login => (
  is      => 'rw',
  default => sub { 1 },
);

has _client => (
  is      => 'ro',
  lazy    => 1,
  default => sub {
    my $self = shift;
    require AnyEvent::FTP::Client;
    my $client = AnyEvent::FTP::Client->new;
    my $cv = AnyEvent->condvar;
    my $timer = AnyEvent->timer(
      after => 5,
      cb    => sub { $cv->croak("timeout connecting with ftp client") },
    );
    if($self->auto_login)
    {
      $client->connect($self->test_uri)
             ->cb(sub { $cv->send });
    }
    else
    {
      $client->connect($self->test_uri->host, $self->test_uri->port)
             ->cb(sub { $cv->send });
    }
    $cv->recv;
    $client;
  },
);


sub create_ftpserver_ok (;$$)
{
  my($context, $message) = @_;

  my $ctx = context();

  my $uri = URI->new("ftp://127.0.0.1");

  $context //= 'Memory';
  $context = "AnyEvent::FTP::Server::Context::$context"
    unless $context =~ /::/;
  my $name = (split /::/, $context)[-1];

  my $user = join '', map { chr(ord('a') + int rand(26)) } (1..10);
  my $pass = join '', map { chr(ord('a') + int rand(26)) } (1..10);
  $uri->userinfo(join(':', $user, $pass));

  my $server;
  eval {
    $server = Test::AnyEventFTPServer->new(
      default_context => $context,
      hostname        => '127.0.0.1',
      port            => undef,
      test_uri        => $uri,
    );

    if($ENV{AEF_DEBUG})
    {
      $server->on_connect(sub {
        my $con = shift;
        $ctx->note("CONNECT");

        $con->on_request(sub {
          my $raw = shift;
          $ctx->note("CLIENT: $raw");
        });

        $con->on_response(sub {
          my $raw = shift;
          $ctx->note("SERVER: $raw");
        });

        $con->on_close(sub {
          $ctx->note("DISCONNECT");
        });
      });
    }

    $server->on_connect(sub {
      shift->context->authenticator(sub {
        return $_[0] eq $user && $_[1] eq $pass;
      });
    });

    my $cv = AnyEvent->condvar;
    my $timer = AnyEvent->timer(
      after => 5,
      cb    => sub { $cv->croak("timeout creating ftp server") },
    );
    $server->on_bind(sub {
      $uri->port(shift);
      $cv->send;
    });
    $server->start;
    $cv->recv;
  };
  my $error = $@;

  $message //= "created FTP ($name) server at $uri";

  $ctx->ok($error eq '', $message);
  $ctx->diag($error) if $error;
  $ctx->release;

  $server;
}


sub connect_ftpclient_ok
{
  my($self, $message) = @_;
  my $client;
  eval {
    require AnyEvent::FTP::Client;
    $client = AnyEvent::FTP::Client->new;
    my $cv = AnyEvent->condvar;
    my $timer = AnyEvent->timer(
      after => 5,
      cb    => sub { $cv->croak("timeout connecting with ftp client") },
    );
    if($self->auto_login)
    {
      $client->connect($self->test_uri)
             ->cb(sub { $cv->send });
    }
    else
    {
      $client->connect($self->tesT_uri->host, $self->test_uri->port)
             ->cb(sub { $cv->send });
    }
    $cv->recv;
  };
  my $error = $@;

  $message //= "connected to FTP server at " . $self->test_uri;

  my $ctx = context();
  $ctx->ok($error eq '', $message);
  $ctx->diag($error) if $error;
  $ctx->release;

  $client;
}


sub help_coverage_ok
{
  my($self, $class, $message) = @_;

  $class //= $self->default_context;

  my @missing;

  my $client = eval { $self->_client };
  my $error = $@;

  my $count = 0;
  unless($error)
  {
    foreach my $cmd (map { uc $_ } grep s/^cmd_//,  eval qq{ use $class; keys \%${class}::;})
    {
      if((eval { $client->help($cmd)->recv } || $@)->code != 214)
      { push @missing, $cmd }
      $count++;
    }
  }

  $message //= "help coverage for $class";

  my $ctx = context();
  $ctx->ok($error eq '' && @missing == 0, $message);
  $ctx->diag($error) if $error;
  $ctx->diag("commands missing help: @missing") if @missing;
  $ctx->diag("didn't find ANY commands for class: $class")
    if $count == 0;
  $ctx->release;

  $self;
}


sub command_ok
{
  my($self, $command, $args, $message) = @_;

  my $client = eval { $self->_client };
  my $error = $@;

  unless($error)
  {
    my $res = (eval { $client->push_command([$command, $args])->recv } || $@);
    if(eval { $res->isa('AnyEvent::FTP::Client::Response') })
    { $self->res($res) }
    else
    { $error = $res; $self->res(undef) }
  }

  $message //= "command: $command";

  my $ctx = context();
  $ctx->ok($error eq '', $message);
  $ctx->diag($error) if $error;
  $ctx->release;

  $self;
}


sub code_is
{
  my($self, $code, $message) = @_;

  $message //= "response code is $code";

  my $ctx = context();
  my $actual = eval { $self->res->code } // 'undefined';
  $ctx->ok($actual == $code, $message);
  $ctx->diag("actual code returned is $actual")
    unless $actual == $code;
  $ctx->release;

  $self;
}


sub code_like
{
  my($self, $regex, $message) = @_;

  $message //= "response code matches";

  my $ctx = context();
  my $actual = eval { $self->res->code } // 'undefined';
  $ctx->ok($actual =~ $regex, $message);
  $ctx->diag("code $actual does not match $regex")
    unless $actual =~ $regex;
  $ctx->release;

  $self;
}


sub message_like
{
  my($self, $regex, $message) = @_;

  $message //= "response message matches";

  my $ok = 0;

  my @message = @{ (eval { $self->res->message }) // [] };
  foreach my $line (@message)
  {
    $ok = 1 if $line =~ $regex;
  }

  my $ctx = context();
  $ctx->ok($ok, $message);
  unless($ok)
  {
    $ctx->diag("message: ");
    $ctx->diag("  $_") for @message;
    $ctx->diag("does not match $regex");
  }
  $ctx->release;

  $self;
}


sub message_is
{
  my($self, $string, $message) = @_;

  $message //= "response message matches";

  my $ok = 0;

  my @message = @{ (eval { $self->res->message }) // [] };

  foreach my $line (@message)
  {
    $ok = 1 if $line eq $string;
  }

  my $ctx = context();
  $ctx->ok($ok, $message);
  unless($ok)
  {
    $ctx->diag("message: ");
    $ctx->diag("  $_") for @message;
    $ctx->diag("does not match $string");
  }
  $ctx->release;

  $self;
}


sub list_ok
{
  my($self, $location, $message) = @_;

  $message //= defined $location ? "list: $location" : 'list';

  my $client = eval { $self->_client };
  my $error = $@;

  $self->content('');

  unless($error)
  {
    my $list = eval { $client->list($location)->recv };
    $error = $@;
    $self->content(join "\n", @$list, '') unless $error;
  }

  my $ctx = context();
  $ctx->ok($error eq '', $message);
  $ctx->diag($error) if $error;
  $ctx->release;

  $self;
}


sub nlst_ok
{
  my($self, $location, $message) = @_;

  $message //= defined $location ? "nlst: $location" : 'nlst';

  my $client = eval { $self->_client };
  my $error = $@;

  $self->content('');

  unless($error)
  {
    my $list = eval { $client->nlst($location)->recv };
    $error = $@;
    $self->content(join "\n", @$list, '') unless $error;
  }

  my $ctx = context();
  $ctx->ok($error eq '', $message);
  $ctx->diag($error) if $error;
  $ctx->release;

  $self;
}


sub _display_content
{
  state $temp;
  state $counter = 0;
  my $method = 'diag';
  #$method = 'note' if $tb->todo;

  unless(defined $temp)
  {
    $temp = tempdir(CLEANUP => 1);
  }

  my $file = $temp->file(sprintf("data.%d", $counter++));
  $file->spew($_[0]);

  my $ctx = context();

  if(-T $file)
  {
    $ctx->$method("  $_") for split /\n/, $_[0];
  }
  else
  {
    if(eval { require Data::HexDump })
    {
      $ctx->$method("  $_") for grep !/^$/, split /\n/, Data::HexDump::HexDump($_[0]);
    }
    else
    {
      $ctx->$method("  binary content");
    }
  }

  $ctx->release;

  $file->remove;
}

sub content_is
{
  my($self, $string, $message) = @_;

  $message ||= 'content matches';

  my $ok = $self->content eq $string;

  my $ctx = context();
  $ctx->ok($ok, $message);
  unless($ok)
  {
    $ctx->diag("content:");
    _display_content($self->content);
    $ctx->diag("expected:");
    _display_content($string);
  }

  $ctx->release;

  $self;
}


sub global_timeout_ok (;$$)
{
  my($timeout, $message) = @_;

  $timeout //= 120;
  $message //= "global timeout of $timeout seconds";

  my $ctx = context();

  state $timers = [];

  eval {
    push @$timers, AnyEvent->timer(
      after => $timeout,
      cb    => sub { $ctx->diag("GLOBAL TIMEOUT"); exit },
    );
  };
  my $error = $@;

  my $ok = $error eq '';

  $ctx->ok($ok, $message);
  $ctx->diag($error) if $error;

  $ctx->release;

  $ok;
}

sub import
{
  my $caller = caller;
  no strict 'refs';
  *{join '::', $caller, 'create_ftpserver_ok'} = \&create_ftpserver_ok;
  *{join '::', $caller, 'global_timeout_ok'} = \&global_timeout_ok;
}

BEGIN { eval 'use EV' }

1;

__END__