qpsmtpd/t/Test/Qpsmtpd.pm

package Test::Qpsmtpd;
use strict;

use Carp qw(croak);
use Test::More;

use lib 't';
use lib 'lib';
use parent 'Qpsmtpd::SMTP';

use Qpsmtpd::Constants;
use Test::Qpsmtpd::Plugin;

if ( ! -d 't/tmp' ) {
    mkdir 't/tmp' or warn "Could not create temporary testing directory:$!";
}

sub new_conn {
    ok(my $smtpd = __PACKAGE__->new(), "new");
    ok(
        my $conn =
          $smtpd->start_connection(
                                   remote_host => 'localhost',
                                   remote_ip   => '127.0.0.1'
                                  ),
        "start_connection"
      );
    is(($smtpd->response)[0], "220", "greetings");
    ($smtpd, $conn);
}

sub start_connection {
    my $self = shift;
    my %args = @_;

    my $remote_host = $args{remote_host} or croak "no remote_host parameter";
    my $remote_info = "test\@$remote_host";
    my $remote_ip   = $args{remote_ip} or croak "no remote_ip parameter";

    my $conn =
      $self->SUPER::connection->start(
                                      remote_info => $remote_info,
                                      remote_ip   => $remote_ip,
                                      remote_host => $remote_host,
                                      @_
                                     );

    $self->load_plugins;

    my $rc = $self->start_conversation;
    return if $rc != DONE;

    $conn;
}

sub respond {
    my $self = shift;
    $self->{_response} = [@_];
}

sub response {
    my $self = shift;
    $self->{_response} ? (@{delete $self->{_response}}) : ();
}

sub command {
    my ($self, $command) = @_;
    $self->input($command);
    $self->response;
}

sub input {
    my ($self, $command) = @_;

    my $timeout = $self->config('timeout');
    alarm $timeout;

    $command =~ s/\r?\n$//s;    # advanced chomp
    $self->log(LOGDEBUG, "dispatching $command");
    if (!defined $self->dispatch(split / +/, $command, 2)) {
        $self->respond(502, "command unrecognized: '$command'");
    }
    alarm $timeout;
}

sub config_dir {
    return './t/config' if $ENV{QPSMTPD_DEVELOPER};
    return './config.sample';
}

sub plugin_dirs {
    ('./plugins', './plugins/ident');
}

sub log {
    my ($self, $trace, $hook, $plugin, @log) = @_;
    my $level = Qpsmtpd::TRACE_LEVEL() || 5;
    $level = $self->init_logger if !defined $level;
    return if $trace > $level;
    print("# " . join(' ', $$, @log) . "\n");
    ( undef, undef, my @record_args ) = @_;
    push @{ $self->{_logged} }, log_level($trace) . ":"
      . join '', grep { defined } @record_args;
}

sub varlog {
    shift->log(@_);
}

# sub run
# sub disconnect

sub run_plugin_tests {
    my ($self, $only_plugin) = @_;
    $self->{_test_mode} = 1;
    my @plugins = $self->load_plugins();

    require Test::Builder;
    my $Test = Test::Builder->new();

    foreach my $plugin (@plugins) {
        next if ($only_plugin && $plugin !~ /$only_plugin/);
        $plugin->register_tests();
        $plugin->run_tests($self);
    }
    $Test->done_testing();
}

sub fake_hook {
    ###########################################################################
    # Inserts a given subroutine into the beginning of the set of hooks already
    # in place. Used to test code against different potential plugins it will
    # interact with. For example, to test behavior against various results of
    # the data_post hook:
    #
    # $self->fake_hook('data_post',sub { return DECLINED };
    # ok(...);
    # $self->fake_hook('data_post',sub { return DENYSOFT };
    # ok(...);
    # $self->fake_hook('data_post',sub { return DENY };
    # ok(...);
    # $self->fake_hook('data_post',sub { return DENY_DISCONNECT };
    # ok(...);
    # $self->unfake_hook('data_post');
    ###########################################################################
    my ( $self, $hook, $sub ) = @_;
    unshift @{ $self->hooks->{$hook} ||= [] },
        {
            name => '___FakeHook___',
            code => $sub,
        };
}

sub unfake_hook {
    my ( $self, $hook ) = @_;
    $self->hooks->{$hook} = [
        grep { $_->{name} ne '___FakeHook___' }
        @{ $self->hooks->{$hook} || [] }
    ];
}

sub fake_config {
    ####################################################################
    # Used to test code against various possible configurations
    # For example, to test against various possible config('me') values:
    #
    # $self->fake_config( me => '***invalid***' );
    # ok(...);
    # $self->fake_config( me => 'valid-nonfqdn' );
    # ok(...);
    # $self->fake_config( me => 'valid-fqdn.com');
    # ok(...);
    # $self->unfake_config();
    ####################################################################
    my $self = shift;
    my $fake_config = {@_};
    $self->fake_hook( 'config',
        sub {
            my ( $self, $txn, $conf ) = @_;
            return DECLINED if ! exists $fake_config->{$conf};
            return OK, $fake_config->{$conf};
    } );
}

sub unfake_config {
    my ( $self ) = @_;
    $self->unfake_hook('config');
}

1;