moving some more test modules to lib

lib/WebGUI/Test/MailServer.pm

@@ -0,0 +1,151 @@
+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
+
+=head1 SUBROUTINES
+
+=head2 test_smtp ( $session, $testSub )
+
+Sets up a SMTP server and runs a test sub against it.  The test sub will be called with a callback sub as a parameter.  Calling that callback will return a hash ref with four keys.
+
+=over 8
+
+=item to
+
+Contains an array of addresses the message was sent to.
+
+=item from
+
+Contains the address the message was sent from.
+
+=item contents
+
+Contains the raw contents of the mail message.
+
+=item parsed
+
+Contains the mail message as a L<MIME::Entity> object.
+
+=back
+
+=cut
+
+use strict;
+use warnings;
+
+use JSON ();
+use IO::Select;
+use Net::SMTP::Server;
+use Net::SMTP::Server::Client;
+use MIME::Parser;
+use Scope::Guard;
+use MIME::Parser;
+use POSIX ();
+
+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;
+
+    $smtpdPid = open $smtpdStream, '-|';
+    if ( ! defined $smtpdPid ) {
+        die "Could not open pipe to SMTPD: $!";
+    }
+    # child
+    elsif ( ! $smtpdPid ) {
+        $SIG{INT} = sub {
+            POSIX::_exit(0);
+        };
+        _run_server($host, $port);
+        POSIX::_exit(0);
+    }
+    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;
+    }
+}
+
+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;
+