separate out SMTP testing into its own module
This commit is contained in:
Graham Knop
parent
8c2c2f0a8d
commit
bc5df47fed
4 changed files with 242 additions and 290 deletions
|
|
@ -523,57 +523,6 @@ sub getSmokeLDAPProps {
|
|||
|
||||
#----------------------------------------------------------------------------
|
||||
|
||||
=head2 prepareMailServer ( )
|
||||
|
||||
Prepare a Net::SMTP::Server to use for testing mail.
|
||||
|
||||
=cut
|
||||
|
||||
my $smtpdPid;
|
||||
my $smtpdStream;
|
||||
my $smtpdSelect;
|
||||
|
||||
sub prepareMailServer {
|
||||
eval {
|
||||
require Net::SMTP::Server;
|
||||
require Net::SMTP::Server::Client;
|
||||
};
|
||||
croak "Cannot load Net::SMTP::Server: $@" if $@;
|
||||
|
||||
my $SMTP_HOST = 'localhost';
|
||||
my $SMTP_PORT = '54921';
|
||||
my $smtpd = File::Spec->catfile( $CLASS->root, 't', 'smtpd.pl' );
|
||||
$smtpdPid = open $smtpdStream, '-|', $^X, $smtpd, $SMTP_HOST, $SMTP_PORT
|
||||
or die "Could not open pipe to SMTPD: $!";
|
||||
|
||||
$smtpdSelect = IO::Select->new;
|
||||
$smtpdSelect->add($smtpdStream);
|
||||
|
||||
$CLASS->session->setting->set( 'smtpServer', $SMTP_HOST . ':' . $SMTP_PORT );
|
||||
|
||||
$CLASS->originalConfig('emailToLog');
|
||||
$CLASS->session->config->set( 'emailToLog', 0 );
|
||||
|
||||
# Let it start up yo
|
||||
sleep 2;
|
||||
|
||||
$CLASS->addToCleanup(sub {
|
||||
# Close SMTPD
|
||||
if ($smtpdPid) {
|
||||
kill INT => $smtpdPid;
|
||||
}
|
||||
if ($smtpdStream) {
|
||||
# we killed it, so there will be an error. Prevent that from setting the exit value.
|
||||
local $?;
|
||||
close $smtpdStream;
|
||||
}
|
||||
});
|
||||
|
||||
return;
|
||||
}
|
||||
|
||||
#----------------------------------------------------------------------------
|
||||
|
||||
=head2 originalConfig ( $param )
|
||||
|
||||
Stores the original data from the config file, to be restored
|
||||
|
|
@ -606,63 +555,6 @@ sub originalConfig {
|
|||
|
||||
#----------------------------------------------------------------------------
|
||||
|
||||
=head2 getMail ( )
|
||||
|
||||
Read a sent mail from the prepared mail server (L<prepareMailServer>)
|
||||
|
||||
=cut
|
||||
|
||||
sub getMail {
|
||||
my $json;
|
||||
|
||||
if ( !$smtpdSelect ) {
|
||||
return from_json ' { "error": "mail server not prepared" }';
|
||||
}
|
||||
|
||||
if ($smtpdSelect->can_read(5)) {
|
||||
$json = <$smtpdStream>;
|
||||
}
|
||||
else {
|
||||
$json = ' { "error": "mail not sent" } ';
|
||||
}
|
||||
|
||||
if (!$json) {
|
||||
$json = ' { "error": "error in getting mail" } ';
|
||||
}
|
||||
|
||||
return from_json( $json );
|
||||
}
|
||||
|
||||
#----------------------------------------------------------------------------
|
||||
|
||||
=head2 getMailFromQueue ( )
|
||||
|
||||
Send the first mail in the queue and then retrieve it from the smtpd. Returns
|
||||
false if there is no mail in the queue.
|
||||
|
||||
Will prepare the server if necessary
|
||||
|
||||
=cut
|
||||
|
||||
sub getMailFromQueue {
|
||||
my $class = shift;
|
||||
if ( !$smtpdSelect ) {
|
||||
$class->prepareMailServer;
|
||||
}
|
||||
|
||||
my $messageId = $CLASS->session->db->quickScalar( "SELECT messageId FROM mailQueue" );
|
||||
warn $messageId;
|
||||
return unless $messageId;
|
||||
|
||||
require WebGUI::Mail::Send;
|
||||
my $mail = WebGUI::Mail::Send->retrieve( $CLASS->session, $messageId );
|
||||
$mail->send;
|
||||
|
||||
return $class->getMail;
|
||||
}
|
||||
|
||||
#----------------------------------------------------------------------------
|
||||
|
||||
=head2 cleanupGuard ( $object, $class => $ident )
|
||||
|
||||
Pass in a list of objects or pairs of classes and identifiers, and
|
||||
|
|
|
|||
137
t/lib/WebGUI/Test/MailServer.pm
Normal file
137
t/lib/WebGUI/Test/MailServer.pm
Normal file
|
|
@ -0,0 +1,137 @@
|
|||
package WebGUI::Test::MailServer;
|
||||
|
||||
=head1 LEGAL
|
||||
|
||||
-------------------------------------------------------------------
|
||||
WebGUI is Copyright 2001-2009 Plain Black Corporation.
|
||||
-------------------------------------------------------------------
|
||||
Please read the legal notices (docs/legal.txt) and the license
|
||||
(docs/license.txt) that came with this distribution before using
|
||||
this software.
|
||||
-------------------------------------------------------------------
|
||||
http://www.plainblack.com info@plainblack.com
|
||||
-------------------------------------------------------------------
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Package WebGUI::Test::MailServer
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
Routines for testing mail sending in WebGUI
|
||||
|
||||
=cut
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
use JSON ();
|
||||
use File::Spec::Functions qw(catdir updir);
|
||||
use File::Basename qw(dirname);
|
||||
use IO::Select;
|
||||
use Net::SMTP::Server;
|
||||
use Net::SMTP::Server::Client;
|
||||
use MIME::Parser;
|
||||
use Scope::Guard;
|
||||
use MIME::Parser;
|
||||
|
||||
my $smtpdPid;
|
||||
my $smtpdStream;
|
||||
my $smtpdSelect;
|
||||
|
||||
sub test_smtp {
|
||||
my $session = shift;
|
||||
my $testSub = shift;
|
||||
my $guard = Scope::Guard->new(sub { _shutdown_server() } );
|
||||
_setup_server($session);
|
||||
sleep 1;
|
||||
my $parser = MIME::Parser->new;
|
||||
$parser->output_to_core(1);
|
||||
my $cb = sub {
|
||||
die "mail not sent\n"
|
||||
unless $smtpdSelect->can_read(5);
|
||||
my $json = <$smtpdStream>;
|
||||
my $data = JSON->new->utf8->decode($json);
|
||||
my $parsed = $parser->parse_data($data->{contents});
|
||||
$data->{parsed} = $parsed;
|
||||
return $data;
|
||||
};
|
||||
$testSub->($cb);
|
||||
}
|
||||
|
||||
sub _setup_server {
|
||||
my $session = shift;
|
||||
return
|
||||
if $smtpdPid;
|
||||
|
||||
my $host = 'localhost';
|
||||
my $port = 54921;
|
||||
|
||||
# make sure the lib path for this file is available
|
||||
my $lib_path = catdir( dirname(__FILE__), (updir) x 2 );
|
||||
my @command_line = (
|
||||
$^X, "-I$lib_path", '-M' . __PACKAGE__,
|
||||
'-e' . __PACKAGE__ . '::run_server(@ARGV)', $host, $port,
|
||||
);
|
||||
|
||||
$smtpdPid = open $smtpdStream, '-|', @command_line
|
||||
or die "Could not open pipe to SMTPD: $!";
|
||||
die "Could not open pipe to SMTPD: $!"
|
||||
unless $smtpdStream;
|
||||
|
||||
$smtpdSelect = IO::Select->new;
|
||||
$smtpdSelect->add($smtpdStream);
|
||||
|
||||
$session->setting->set( 'smtpServer', $host . ':' . $port );
|
||||
$session->config->set( 'emailToLog', 0 );
|
||||
}
|
||||
|
||||
sub _shutdown_server {
|
||||
undef $smtpdSelect;
|
||||
|
||||
# Close SMTPD
|
||||
if ($smtpdPid) {
|
||||
kill INT => $smtpdPid;
|
||||
undef $smtpdPid;
|
||||
}
|
||||
if ($smtpdStream) {
|
||||
# we killed it, so there will be an error. Prevent that from setting the exit value.
|
||||
local $?;
|
||||
close $smtpdStream;
|
||||
undef $smtpdStream;
|
||||
}
|
||||
}
|
||||
|
||||
=head2 getMail ( )
|
||||
|
||||
Read a sent mail from the prepared mail server (L<prepareMailServer>)
|
||||
|
||||
=cut
|
||||
|
||||
sub getMail {
|
||||
my $json;
|
||||
|
||||
if ($smtpdSelect->can_read(5)) {
|
||||
$json = <$smtpdStream>;
|
||||
}
|
||||
return from_json( $json );
|
||||
}
|
||||
|
||||
sub run_server {
|
||||
my ($host, $port) = @_;
|
||||
my $server = Net::SMTP::Server->new( $host, $port );
|
||||
local $| = 1;
|
||||
CONNECTION: while ( my $conn = $server->accept ) {
|
||||
my $client = Net::SMTP::Server::Client->new( $conn );
|
||||
$client->process;
|
||||
print JSON->new->utf8->encode({
|
||||
to => $client->{TO},
|
||||
from => $client->{FROM},
|
||||
contents => $client->{MSG},
|
||||
});
|
||||
print "\n";
|
||||
}
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
Loading…
Add table
Add a link
Reference in a new issue