Test::SMTP - Module for writing SMTP Server tests

Test-SMTP documentation Contained in the Test-SMTP distribution.

Index

Code Index:

NAME

Top

Test::SMTP - Module for writing SMTP Server tests

SYNOPSIS

Top

    use Test::SMTP;

    plan tests => 10;
    # Constructors
    my $client1 = Test::SMTP->connect_ok('connect to mailhost',
                                         Host => '127.0.0.1', AutoHello => 1);
    $client1->mail_from_ok('test@example.com', 'Accept an example mail from');
    $client1->rcpt_to_ko('test2@example.com', 'Reject an example domain in rcpt to');
    $client1->quit_ok('Quit OK');
    my $client2 = Test::SMTP->connect_ok('connect to mailhost',
                                         Host => '127.0.0.1', AutoHello => 1);
    ...

DESCRIPTION

Top

This module is designed for easily building tests for SMTP servers.

Test::SMTP is a subclass of Net::SMTP_auth, that is a subclass of Net::SMTP, that in turn is a subclass of Net::Cmd and IO::Socket::INET. Don't be too confident of it beeing a Net::SMTP_auth subclass for too much time, though (v 0.03 changed from Net::SMTP to Net::SMTP_auth so you can control authentication tests better). Compatibility will always try to be kept so you can still call the subclass methods.

PLAN

Top

plan

Plan tests a la Test::More. Exported on demand (not necessary to export if you are already using a test module that exports plan). 

  use Test::SMTP qw(plan);
  plan tests => 5;

CONSTRUCTOR

Top

connect_ok($name, Host => $host, AutoHello => 1, [ Timeout => 1 ])

Passes if the client connects to the SMTP Server. Everything after name is passed to the Net::SMTP_auth new method. returns a Test::SMTP object.

Net::SMTP_auth parameters of interest: Port => $port (connect to non-standard SMTP port) Hello => 'my (he|eh)lo' hello to send to the server Debug => 1 Outputs via STDERR the conversation with the server

You have to pass AutoHello => 1, this will enable auto EHLO/HELO negotiation.

connect_ko($name, Host => $host, [ Timeout => 1 ])

Passes test if the client does not connect to the SMTP Server. Everything after name is passed to the Net::SMTP_auth new method.

TEST METHODS

Top

code_is ($expected, $name)

Passes if the last SMTP code returned by the server was expected.

code_isnt ($expected, $name)

Passes if the last SMTP code returned by the server was'nt expected.

code_is_success($name)

Passes if the last SMTP code returned by the server indicates success.

code_isnt_success($name)

Passes if the last SMTP code returned by the server doesn't indicate success.

code_is_failure($name)

Passes if the last SMTP code returned by the server indicates failure (either temporary or permanent).

code_isnt_failure($name)

Passes if the last SMTP code returned by the server doesn't indicate failure (either temporary or permanent).

code_is_temporary($name)

Passes if the last SMTP code returned by the server indicates temporary failure

code_isnt_temporary($name)

Passes if the last SMTP code returned by the server doesn't indicate temporary failure

code_is_permanent($name)

Passes if the last SMTP code returned by the server indicates permanent failure

code_isnt_permanent($name)

Passes if the last SMTP code returned by the server doesn't indicate permanent failure

message_like(qr/REGEX/, $name)

Passes if the last SMTP message returned by the server matches the regex.

message_unlike(qr/REGEX/, $name)

Passes if the last SMTP message returned by the server does'nt match the regex.

auth_ok($method, $user, $password, $name)

Passes if $user with $password with SASL method $method is AUTHorized on the server.

auth_ko($method, $user, $password, $name)

Passes if $user with $password with SASL method $method is not AUTHorized on the server.

starttls_ok($name)

Start TLS conversation with the server. Pass if server said that it's OK to start TLS and the SSL negotiation went OK.

starttls_ko($name)

Start TLS conversation with the server. Pass if server said that it's not OK to start TLS or if the SSL negotiation failed.

hello_ok($hello, $name)

Do EHLO/HELO negotiation. Useful only after starttls_ok/ko

hello_ko($hello, $name)

Do EHLO/HELO negotiation. Useful only after starttls_ok/ko

rset_ok($name)

Send a RSET command to the server. Pass if command was successful

rset_ko($name)

Send an RSET to the server. Pass if command was not successful

supports_ok($capa, $name)

Passes test if server said it supported capa capability on ESMTP EHLO

supports_ko($capa, $name)

Passes test if server didn't say it supported capa capability on ESMTP EHLO

supports_cmp_ok($capability, $operator, $expected, $name)

Compares server capa capability extra information with operator against expected.

supports_like($capability, qr/REGEX/, $name)

Passes if server capa capability extra information matches against REGEX.

supports_unlike($capability, qr/REGEX/, $name)

Passes if server capa capability extra information doesn't match against REGEX.

Passes if server banner matches against REGEX.

Passes if server banner doesn't match against REGEX.

domain_like(qr/REGEX/, $name)

Passes if server's announced domain matches against REGEX.

domain_unlike(qr/REGEX/, $name)

Passes if server's announced domain doesn't match against REGEX.

mail_from_ok($from, $name)

Sends a MAIL FROM: from to the server. Passes if the command succeeds

mail_from_ko($from, $name)

Sends a MAIL FROM: from to the server. Passes if the command isn't successful

rcpt_to_ok($to, $name)

Sends a RCPT TO: to to the server. Passes if the command succeeds

rcpt_to_ko($to, $name)

Sends a RCPT TO: to to the server. Passes if the command isn't successful

data_ok($name)

Sends a DATA command to the server. Passes if the command is successful. After calling this method, you should call datasend.

data_ko($name)

Sends a DATA command to the server. Passes if the command is'nt successful

dataend_ok($name)

Sends a .<CR><LF> command to the server. Passes if the command is successful.

dataend_ko($name)

Sends a .<CR><LF> command to the server. Passes if the command is not successful.

help_like([HELP_ON], qr/REGEX/, $name)

Sends HELP HELP_ON command to the server. If the returned text matches REGEX, the test passes. To test plain HELP command, pass undef in HELP_ON.

help_unlike([HELP_ON], qr/REGEX/, $name)

Sends HELP HELP_ON command to the server. If the returned text doesn't match REGEX, the test passes. To test plain HELP command, pass undef in HELP_ON.

quit_ok($name)

Send a QUIT command to the server. Pass if command was successful

quit_ko($name)

Send a QUIT command to the server. Pass if command was'nt successful

NON TEST METHODS

Top

mail_from($from)

Issues a MAIL FROM: from command to the server.

rcpt_to($to)

Issues a RCPT TO: to command to the server.

AUTHOR

Top

    Jose Luis Martinez
    CAPSiDE
    jlmartinez@capside.com
    http://www.pplusdomain.net/
    http://www.capside.com/

COPYRIGHT

Top

This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself.

The full text of the license can be found in the LICENSE file included with this module.

Test-SMTP documentation Contained in the Test-SMTP distribution. 
package Test::SMTP;

use strict;
use warnings;

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

    use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS);
    $VERSION     = '0.04';
    @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 undef;
    }

    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 undef;
    }

    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) = @_;
    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()){
        $tb->ok(0, $name);
        $tb->diag('SSL: ' . IO::Socket::SSL::errstr());
        return;
    }

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


sub starttls_ko {
    my ($self, $name) = @_;
    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()){
        $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) = @_;
    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)
      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();

    $tb->like($self->help($help_on), $expected, $name);
}


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

    $tb->unlike($self->help($help_on), $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;