view release on metacpan or  search on metacpan

lib/Test/AnyEventFTPServer.pm  view on Meta::CPAN

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.20'; # 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;

lib/Test/AnyEventFTPServer.pm  view on Meta::CPAN

  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__

=pod

=encoding UTF-8

=head1 NAME

Test::AnyEventFTPServer - Test (non-blocking) ftp clients against a real FTP server

=head1 VERSION

version 0.20

=head1 SYNOPSIS

 use Test2:V0;
 use Test::AnyEventFTPServer;
 
 # exit this script after 30s to avoid hung test
 global_timeout_ok;
 
 # $test_server isa AnyEvent::FTP::Server
 # and          isa Test::AnyEventFTPServer
 my $test_server = create_ftpserver_ok;
 
 $test_server->command_ok('HELP')
             ->code_is(214)
             ->message_like(qr{the following commands are recognize});
 
 # $res isa AnyEvent::FTP::Client::Response
 # from that last HELP command