File Coverage

blib/lib/Test/SMTP.pm

Criterion	Covered	Total	%
statement	231	285	81.0
branch	54	74	72.9
condition	6	6	100.0
subroutine	50	57	87.7
pod	46	46	100.0
total	387	468	82.6

package Test::SMTP;

use strict;
use warnings;

our $VERSION = '0.05'; # VERSION
# ABSTRACT: Module for writing SMTP Server tests

BEGIN {
    use Exporter ();
    use Carp;
    use Net::SMTP_auth;
    use Test::Builder::Module;

    use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS);
    @ISA         = qw(Net::SMTP_auth Test::Builder::Module);
    #Give a hoot don't pollute, do not export more than needed by default
    @EXPORT      = qw();
    @EXPORT_OK   = qw(plan);
    %EXPORT_TAGS = ();
}


sub plan {
    my $tb = __PACKAGE__->builder;
    $tb->plan(@_);
}


sub connect_ok {
    my ($class, $name, %params) = @_;

    if ((not defined($params{'AutoHello'})) or ($params{'AutoHello'} != 1)){
        croak "Can only handle AutoHello for now...";
    }

    my $smtp = Net::SMTP_auth->new(%params);

    my $tb = __PACKAGE__->builder();
    $tb->ok(defined $smtp, $name);

    if (not defined($smtp)){
        return;
    }

    bless $smtp, $class;
    return $smtp;
}


sub connect_ko {
    my ($class, $name, @params) = @_;

    my $smtp = Net::SMTP_auth->new(@params);
    my $tb = __PACKAGE__->builder();

    $tb->ok(not(defined $smtp), $name);

    if (not defined $smtp){
        return;
    }

    bless $smtp, $class;
    return $smtp;
}



sub code_is {
    my ($self, $expected, $name) = @_;
    my $tb = __PACKAGE__->builder();

    $tb->cmp_ok($self->code(), '==', $expected, $name);
}


sub code_isnt {
    my ($self, $expected, $name) = @_;
    my $tb = __PACKAGE__->builder();

    $tb->cmp_ok($self->code(), '!=', $expected, $name);
}


sub code_is_success {
    my ($self, $name) = @_;
    my $tb = __PACKAGE__->builder();

    if (_is_between($self->code(), 200, 399)){
        $tb->ok(1, $name);
    } else {
        $tb->ok(0, $name);
        $self->_smtp_diag;
    }
}


sub code_isnt_success {
    my ($self, $name) = @_;
    my $tb = __PACKAGE__->builder();

    if (_is_between($self->code(), 200, 399)){
        $tb->ok(0, $name);
        $self->_smtp_diag;
    } else {
        $tb->ok(1, $name);
    }
}


sub code_is_failure {
    my ($self, $name) = @_;
    my $tb = __PACKAGE__->builder();

    if (not _is_between($self->code(), 200, 399)){
        $tb->ok(1, $name);
    } else {
        $tb->ok(0, $name);
        $self->_smtp_diag;
    }
}


sub code_isnt_failure {
    my ($self, $name) = @_;
    my $tb = __PACKAGE__->builder();

    if (not _is_between($self->code(), 200, 399)){
        $tb->ok(0, $name);
        $self->_smtp_diag;
    } else {
        $tb->ok(1, $name);
    }
}


sub code_is_temporary {
    my ($self, $name) = @_;
    my $tb = __PACKAGE__->builder();

    if (_is_between($self->code(), 400, 499)){
        $tb->ok(1, $name);
    } else {
        $tb->ok(0, $name);
        $self->_smtp_diag;
    }
}


sub code_isnt_temporary {
    my ($self, $name) = @_;
    my $tb = __PACKAGE__->builder();

    if (_is_between($self->code(), 400, 499)){
        $tb->ok(0, $name);
        $self->_smtp_diag;
    } else {
        $tb->ok(1, $name);
    }
}


sub code_is_permanent {
    my ($self, $name) = @_;
    my $tb = __PACKAGE__->builder();

    if (_is_between($self->code(), 500, 599)){
        $tb->ok(1, $name);
    } else {
        $tb->ok(0, $name);
        $self->_smtp_diag;
    }
}


sub code_isnt_permanent {
    my ($self, $name) = @_;
    my $tb = __PACKAGE__->builder();

    if (_is_between($self->code(), 500, 599)){
        $tb->ok(0, $name);
        $self->_smtp_diag;
    } else {
        $tb->ok(1, $name);
    }
}


sub message_like {
    my ($self, $expected, $name) = @_;
    my $tb = __PACKAGE__->builder();

    my $message = $self->message();
    $tb->like($message, $expected, $name);
}


sub message_unlike {
    my ($self, $expected, $name) = @_;
    my $tb = __PACKAGE__->builder();

    my $message = $self->message();
    $tb->unlike($message, $expected, $name);
}


sub auth_ok {
    my ($self, $method, $user, $password, $name) = @_;
    my $tb = __PACKAGE__->builder();

    my $result = $self->auth($method, $user, $password);
    if ($result){
        $tb->ok(1, $name);
    } else {
        $tb->ok(0, $name);
	$self->_smtp_diag;
    }
}


sub auth_ko {
    my ($self, $method, $user, $password, $name) = @_;
    my $tb = __PACKAGE__->builder();

    my $result = $self->auth($method, $user, $password);
    if ($result){
        $tb->ok(0, $name);
        $self->_smtp_diag;
    } else {
        $tb->ok(1, $name);
    }
}


sub starttls_ok {
    my ($self, $name, @sslargs) = @_;
    my $tb = __PACKAGE__->builder();

    if (not ($self->command('STARTTLS')->response() == Net::Cmd::CMD_OK)){
        $tb->ok(0, $name);
        $self->_smtp_diag;
        return;
    }
    if (not $self->_convert_to_ssl(@sslargs)){
        $tb->ok(0, $name);
        $tb->diag('SSL: ' . IO::Socket::SSL::errstr());
        return;
    }

    $tb->ok(1, $name);
}


sub starttls_ko {
    my ($self, $name, @sslargs) = @_;
    my $tb = __PACKAGE__->builder();

    if (not ($self->command('STARTTLS')->response() == Net::Cmd::CMD_OK)){
        $tb->ok(1, $name);
	return;
    }
    if (not $self->_convert_to_ssl(@sslargs)){
        $tb->ok(1, $name);
	return;
    }

    $tb->ok(0, $name);
    $self->_smtp_diag;
    $tb->diag('And SSL negotiation went OK');
}

sub _convert_to_ssl {
    my ($self, @sslargs) = @_;
    require IO::Socket::SSL or die "starttls requires IO::Socket::SSL";
    # the socket is stored in ${*self}{'_ssl_sock'}.
    # If not, when starttls sub ends *$self is not tied to the SSL
    # socket anymore, instead, it's tied to the old socket.
    my $ssl_sock = IO::Socket::SSL->new_from_fd($self->fileno, @sslargs)
      or return 0;
    ${*self}{'_ssl_sock'} = $ssl_sock;
    *$self = *$ssl_sock;
}


sub hello_ok {
    my ($self, $hello, $name) = @_;
    my $tb = __PACKAGE__->builder();

    if ($self->hello($hello)){
        $tb->ok(1, $name);
    } else {
        $tb->ok(0, $name);
	$self->_smtp_diag;
    }
}


sub hello_ko {
    my ($self, $hello, $name) = @_;
    my $tb = __PACKAGE__->builder();

    if ($self->hello($hello)){
        $tb->ok(0, $name);
        $self->_smtp_diag;
    } else {
        $tb->ok(1, $name);
    }
}



sub rset_ok {
    my ($self, $name) = @_;
    my $tb = __PACKAGE__->builder();

    if ($self->reset){
        $tb->ok(1, $name);
    } else {
        $tb->ok(0, $name);
        $self->_smtp_diag;
    }
}


sub rset_ko {
    my ($self, $name) = @_;
    my $tb = __PACKAGE__->builder();

    if ($self->reset){
        $tb->ok(0, $name);
        $self->_smtp_diag;
    } else {
        $tb->ok(1, $name);
    }
}


sub supports_ok {
    my ($self, $capa, $name) = @_;
    my $tb = __PACKAGE__->builder();

    if (defined $self->supports($capa)){
        $tb->ok(1, $name);
    } else {
        $tb->ok(0, $name);
    }
}


sub supports_ko {
    my ($self, $capa, $name) = @_;
    my $tb = __PACKAGE__->builder();

    if (defined $self->supports($capa)){
        $tb->ok(0, $name);
        $tb->diag("Server supports the feature $capa with " . $self->supports($capa));
    } else {
        $tb->ok(1, $name);
    }
}


sub supports_cmp_ok {
    my ($self, $capa, $operator, $expected, $name) = @_;
    my $tb = __PACKAGE__->builder();

    my $val = $self->supports($capa);
    $tb->cmp_ok($val, $operator, $expected, $name);
}


sub supports_like {
    my ($self, $capa, $expected, $name) = @_;
    my $tb = __PACKAGE__->builder();

    my $val = $self->supports($capa);
    $tb->like($val, $expected, $name);
}


sub supports_unlike {
    my ($self, $capa, $expected, $name) = @_;
    my $tb = __PACKAGE__->builder();

    my $val = $self->supports($capa);
    $tb->unlike($val, $expected, $name);
}


sub banner_like {
    my ($self, $qr, $name) = @_;
    my $tb = __PACKAGE__->builder();

    $tb->like($self->banner(), $qr, $name);
}


sub banner_unlike {
    my ($self, $qr, $name) = @_;
    my $tb = __PACKAGE__->builder();

    $tb->unlike($self->banner(), $qr, $name);
}


sub domain_like {
    my ($self, $qr, $name) = @_;
    my $tb = __PACKAGE__->builder();

    $tb->like($self->domain(), $qr, $name);
}


sub domain_unlike {
    my ($self, $qr, $name) = @_;
    my $tb = __PACKAGE__->builder();

    $tb->unlike($self->domain(), $qr, $name);
}


sub mail_from_ok {
    my ($self, $from, $name) = @_;
    my $tb = __PACKAGE__->builder();

    if ($self->mail_from($from)) {
        $tb->ok(1, $name);
    } else {
        $tb->ok(0, $name);
        $self->_smtp_diag;
    }
}


sub mail_from_ko {
    my ($self, $from, $name) = @_;
    my $tb = __PACKAGE__->builder();

    if (not $self->mail_from($from)) {
        $tb->ok(1, $name);
    } else {
        $tb->ok(0, $name);
        $self->_smtp_diag;
    }
}


sub rcpt_to_ok {
    my ($self, $to, $name) = @_;
    my $tb = __PACKAGE__->builder();

    if ($self->rcpt_to($to)) {
        $tb->ok(1, $name);
    } else {
        $tb->ok(0, $name);
        $self->_smtp_diag;
    }
}


sub rcpt_to_ko {
    my ($self, $to, $name) = @_;
    my $tb = __PACKAGE__->builder();

    if (not $self->rcpt_to($to)) {
        $tb->ok(1, $name);
    } else {
        $tb->ok(0, $name);
        $self->_smtp_diag;
    }
}


sub data_ok {
    my ($self, $name) = @_;
    my $tb = __PACKAGE__->builder();

    if ($self->data == 1){
        $tb->ok(1, $name);
    } else {
        $tb->ok(0, $name);
        $self->_smtp_diag;
    }
}


sub data_ko {
    my ($self, $name) = @_;
    my $tb = __PACKAGE__->builder();

    if ($self->data != 1){
        $tb->ok(1, $name);
    } else {
        $tb->ok(0, $name);
        $self->_smtp_diag;
    }
}

#sub datasend {
#    my ($self, $data) = @_;
#
#    if (ref($data) eq 'ARRAY'){
#        $self::SUPER->datasend($data);
#    }
#}


sub dataend_ok {
    my ($self, $name) = @_;
    my $tb = __PACKAGE__->builder();

    if ($self->dataend() == 1){
        $tb->ok(1, $name);
    } else {
        $tb->ok(0, $name);
        $self->_smtp_diag();
    }
}


sub dataend_ko {
    my ($self, $name) = @_;
    my $tb = __PACKAGE__->builder();

    if ($self->dataend() != 1){
        $tb->ok(1, $name);
    } else {
        $tb->ok(0, $name);
        $self->_smtp_diag();
    }
}


sub help_like {
    my ($self, $help_on, $expected, $name) = @_;
    my $tb = __PACKAGE__->builder();

    my $msg = $self->help(
      defined $help_on ? $help_on : ()
    );
    $tb->like($msg, $expected, $name);
}


sub help_unlike {
    my ($self, $help_on, $expected, $name) = @_;
    my $tb = __PACKAGE__->builder();

    my $msg = $self->help(
      defined $help_on ? $help_on : ()
    );
    $tb->unlike($msg, $expected, $name);
}


sub quit_ok {
    my ($self, $name) = @_;
    my $tb = __PACKAGE__->builder();
    $self->quit();
    if (_is_between($self->code(), 200, 399)){
        $tb->ok(1, $name);
    } else {
        $tb->ok(0, $name);
        $self->_smtp_diag;
    }
}


sub quit_ko {
    my ($self, $name) = @_;
    my $tb = __PACKAGE__->builder();
    $self->quit();
    if (_is_between($self->code(), 200, 399)){
        $tb->ok(0, $name);
        $self->_smtp_diag;
    } else {
        $tb->ok(1, $name);
    }
}

sub _is_between {
    my ($what, $start, $end) = @_;
    return ($what >= $start and $what <= $end);
}

sub _smtp_diag {
    my $self = shift;
    my $tb = __PACKAGE__->builder();
    $tb->diag(sprintf("  Got from server %s %s\n", $self->code, $self->message));
}


sub mail_from {
   return shift->command("MAIL", "FROM:", @_)->response() == Net::Cmd::CMD_OK
}


sub rcpt_to {
   return shift->command("RCPT", "TO:", @_)->response() == Net::Cmd::CMD_OK
}



1;

__END__