separate out SMTP testing into its own module

t/lib/WebGUI/Test/MailServer.pm

@@ -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;
+