Added a simple smtpd for testing
MERGE: Added ability for WebGUI::Test->getPage to work on Operations MERGE: Fix for AdSpace and tests for Operation::AdSpace Fixed Poll's use of JSON Added tests for emailOverride
This commit is contained in:
parent
b27d14f2e5
commit
53ac4be8d1
7 changed files with 315 additions and 99 deletions
|
|
@ -15,7 +15,9 @@
|
|||
use FindBin;
|
||||
use strict;
|
||||
use lib "$FindBin::Bin/../lib";
|
||||
use JSON qw( from_json to_json );
|
||||
use Test::More;
|
||||
use File::Spec;
|
||||
use WebGUI::Test;
|
||||
|
||||
use WebGUI::Mail::Send;
|
||||
|
|
@ -27,10 +29,26 @@ my $session = WebGUI::Test->session;
|
|||
my $mail; # The WebGUI::Mail::Send object
|
||||
my $mime; # for getMimeEntity
|
||||
|
||||
# Load Net::SMTP::Server
|
||||
my $hasServer; # This is true if we have a Net::SMTP::Server module
|
||||
BEGIN {
|
||||
eval { require Net::SMTP::Server; require Net::SMTP::Server::Client; };
|
||||
$hasServer = 1 unless $@;
|
||||
}
|
||||
|
||||
# See if we have an SMTP server to use
|
||||
my ( $smtpd, %oldSettings );
|
||||
my $SMTP_HOST = 'localhost';
|
||||
my $SMTP_PORT = '54921';
|
||||
if ($hasServer) {
|
||||
$oldSettings{ smtpServer } = $session->setting->get('smtpServer');
|
||||
$session->setting->set( 'smtpServer', $SMTP_HOST . ':' . $SMTP_PORT );
|
||||
}
|
||||
|
||||
#----------------------------------------------------------------------------
|
||||
# Tests
|
||||
|
||||
plan tests => 5; # Increment this number for each test you create
|
||||
plan tests => 6; # Increment this number for each test you create
|
||||
|
||||
#----------------------------------------------------------------------------
|
||||
# Test create
|
||||
|
|
@ -106,8 +124,82 @@ is( $mime->parts(0)->as_string =~ m/\n/, $newlines,
|
|||
|
||||
# TODO: Test that addHtml creates a body with the right content type
|
||||
|
||||
#----------------------------------------------------------------------------
|
||||
# Test emailOverride
|
||||
SKIP: {
|
||||
my $numtests = 1; # Number of tests in this block
|
||||
|
||||
# Must be able to write the config, or we'll die
|
||||
if ( !-w File::Spec->catfile( WebGUI::Test::root, 'etc', WebGUI::Test::file() ) ) {
|
||||
skip "Cannot test emailOverride: Can't write new configuration value", $numtests;
|
||||
}
|
||||
|
||||
# Must have an SMTP server, or it's pointless
|
||||
if ( !$hasServer ) {
|
||||
skip "Cannot test emailOverride: Module Net::SMTP::Server not loaded!", $numtests;
|
||||
}
|
||||
|
||||
# Override the emailOverride
|
||||
my $oldEmailOverride = $session->config->get('emailOverride');
|
||||
$session->config->set( 'emailOverride', 'dufresne@localhost' );
|
||||
|
||||
# Send the mail
|
||||
my $mail
|
||||
= WebGUI::Mail::Send->create( $session, {
|
||||
to => 'norton@localhost',
|
||||
} );
|
||||
$mail->addText( 'His judgement cometh and that right soon.' );
|
||||
|
||||
my $received = sendToServer( $mail );
|
||||
|
||||
skip "Cannot test emailOverride: No response received from smtpd", $numtests;
|
||||
|
||||
# Test the mail
|
||||
like( $received->{to}->[0], qr/dufresne\@localhost/,
|
||||
"Email TO: address is overridden",
|
||||
);
|
||||
|
||||
# Restore the emailOverride
|
||||
$session->config->set( 'emailOverride', $oldEmailOverride );
|
||||
}
|
||||
|
||||
#----------------------------------------------------------------------------
|
||||
# Cleanup
|
||||
END {
|
||||
|
||||
for my $name ( keys %oldSettings ) {
|
||||
$session->setting->set( $name, $oldSettings{ $name } );
|
||||
}
|
||||
}
|
||||
|
||||
#----------------------------------------------------------------------------
|
||||
# sendToServer ( mail )
|
||||
# Spawns a server (using t/smtpd.pl), sends the mail, and grabs it from the
|
||||
# child
|
||||
# The child process builds a Net::SMTP::Server and listens for the parent to
|
||||
# send the mail. The entire result is returned as a hash reference with the
|
||||
# following keys:
|
||||
#
|
||||
# to - who the mail was to
|
||||
# from - who the mail was from
|
||||
# contents - The complete contents of the message, suitable to be parsed
|
||||
# by a MIME::Entity parser
|
||||
sub sendToServer {
|
||||
my $mail = shift;
|
||||
|
||||
my $smtpd = File::Spec->catfile( WebGUI::Test->root, 't', 'smtpd.pl' );
|
||||
open MAIL, "perl $smtpd $SMTP_HOST $SMTP_PORT |"
|
||||
or die "Could not open pipe to SMTPD: $!";
|
||||
sleep 1; # Give the smtpd time to establish itself
|
||||
|
||||
$mail->send;
|
||||
my $json;
|
||||
while ( my $line = <MAIL> ) {
|
||||
$json .= $line;
|
||||
}
|
||||
|
||||
close MAIL
|
||||
or die "Could not close pipe to SMTPD: $!";
|
||||
|
||||
return from_json( $json );
|
||||
}
|
||||
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue