moving some more test modules to lib
This commit is contained in:
Graham Knop
parent
909240c0c1
commit
5e75631f6b
3 changed files with 0 additions and 0 deletions
151
lib/WebGUI/Test/MailServer.pm
Normal file
151
lib/WebGUI/Test/MailServer.pm
Normal file
|
|
@ -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;
|
||||
|
||||
67
lib/WebGUI/Test/Mechanize.pm
Normal file
67
lib/WebGUI/Test/Mechanize.pm
Normal file
|
|
@ -0,0 +1,67 @@
|
|||
package WebGUI::Test::Mechanize;
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
use parent 'Test::WWW::Mechanize::PSGI';
|
||||
|
||||
use WebGUI;
|
||||
use WebGUI::Config;
|
||||
use WebGUI::Session;
|
||||
use WebGUI::Middleware::Session;
|
||||
use Plack::Middleware::NullLogger;
|
||||
use Try::Tiny;
|
||||
|
||||
sub new {
|
||||
my $class = shift;
|
||||
my %options = @_;
|
||||
my $config_file = delete $options{config};
|
||||
my $wg = WebGUI->new( config => $config_file );
|
||||
my $app = $wg->to_app;
|
||||
$app = WebGUI::Middleware::Session->wrap($app, config => $wg->config);
|
||||
$app = Plack::Middleware::NullLogger->wrap($app);
|
||||
$options{app} = $app;
|
||||
my $self = $class->SUPER::new(%options);
|
||||
$self->{_webgui_config} = $wg->config;
|
||||
return $self;
|
||||
}
|
||||
|
||||
sub session {
|
||||
my $self = shift;
|
||||
return $self->{_webgui_session}
|
||||
if $self->{_webgui_session};
|
||||
my $session = WebGUI::Session->open($self->{_webgui_config}, undef, $self->sessionId);
|
||||
$self->{_webgui_session} = $session;
|
||||
return $session;
|
||||
}
|
||||
|
||||
sub sessionId {
|
||||
my $self = shift;
|
||||
return $self->{_webgui_sessionId}
|
||||
if $self->{_webgui_sessionId};
|
||||
my $sessionId;
|
||||
my $cookieName = $self->{_webgui_config}->get('cookieName');
|
||||
$self->cookie_jar->scan(sub {
|
||||
my ($key, $value) = @_[1,2];
|
||||
if ($key eq $cookieName) {
|
||||
$sessionId = $value;
|
||||
}
|
||||
});
|
||||
if (! $sessionId) {
|
||||
die "Unable to find session cookie!";
|
||||
}
|
||||
$self->{_webgui_sessionId} = $sessionId;
|
||||
return $sessionId;
|
||||
}
|
||||
|
||||
sub DESTROY {
|
||||
my $self = shift;
|
||||
try {
|
||||
my $session = $self->session;
|
||||
$session->var->end;
|
||||
$session->close;
|
||||
};
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
200
lib/WebGUI/Test/MockAsset.pm
Normal file
200
lib/WebGUI/Test/MockAsset.pm
Normal file
|
|
@ -0,0 +1,200 @@
|
|||
package WebGUI::Test::MockAsset;
|
||||
|
||||
=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::MockAsset
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
Creates fake WebGUI::Asset objects and sets them up to be returned by WebGUI::Asset's normal constructors.
|
||||
|
||||
=head1 METHODS
|
||||
|
||||
=head2 new ( [ $class ], [ $id ] )
|
||||
|
||||
Creates a new mock asset. If not specified, the class will default to L<WebGUI::Asset>. In addition to the methods listed, it will also include all of the methods from L<Test::MockObject>. The object will automatically be cleaned up and will no longer be returned once it goes out of scope.
|
||||
|
||||
=head2 mock_id ( $assetId, [ $asset_or_sub ] )
|
||||
|
||||
As an object method, sets the asset ID for the object, and also sets the asset to be returned for that ID.
|
||||
|
||||
As a class method, also accepts a second parameter. If the second parameter is a sub, it will be called when the given asset ID is requested. For any other type, the given object will be returned.
|
||||
|
||||
=head2 unmock_id ( [ $assetId ] )
|
||||
|
||||
As an object method, the mocking set up for the object by mock_id will be removed.
|
||||
|
||||
As a class method, mocking will be removed for the given asset ID.
|
||||
|
||||
=head2 mock_url ( $assetUrl, [ $asset_or_sub ] )
|
||||
|
||||
Works the same as mock_id, except for asset URLs instead of IDs.
|
||||
|
||||
=head2 unmock_url ( [ $assetUrl ] )
|
||||
|
||||
Works the same as unmock_id, except for asset URLs instead of IDs.
|
||||
|
||||
=cut
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
use Test::MockObject::Extends;
|
||||
use WebGUI::Asset;
|
||||
use Package::Stash;
|
||||
use Scalar::Util qw(weaken);
|
||||
|
||||
my $CLASS = __PACKAGE__;
|
||||
|
||||
my %mocked_assetIds;
|
||||
my %mocked_assetUrls;
|
||||
|
||||
{
|
||||
my $asset_meta = WebGUI::Asset->meta;
|
||||
$asset_meta->make_mutable;
|
||||
for my $method (qw(newById newPending)) {
|
||||
$asset_meta->add_around_method_modifier($method, sub {
|
||||
my $orig = shift;
|
||||
my $assetId = $_[2];
|
||||
if ($assetId && exists $mocked_assetIds{$assetId}) {
|
||||
my $asset = $mocked_assetIds{$assetId};
|
||||
return $asset->()
|
||||
if ref $asset eq 'CODE';
|
||||
return $asset;
|
||||
}
|
||||
goto $orig;
|
||||
});
|
||||
}
|
||||
for my $method (qw(newByUrl)) {
|
||||
$asset_meta->add_around_method_modifier($method, sub {
|
||||
my $orig = shift;
|
||||
my $assetUrl = $_[2];
|
||||
if ($assetUrl && exists $mocked_assetUrls{$assetUrl}) {
|
||||
my $asset = $mocked_assetUrls{$assetUrl};
|
||||
return $asset->()
|
||||
if ref $asset eq 'CODE';
|
||||
return $asset;
|
||||
}
|
||||
goto $orig;
|
||||
});
|
||||
}
|
||||
$asset_meta->make_immutable;
|
||||
}
|
||||
|
||||
sub new {
|
||||
my $class = shift;
|
||||
my $mock = shift;
|
||||
my $id = shift;
|
||||
|
||||
$mock ||= 'WebGUI::Asset';
|
||||
$mock = Test::MockObject::Extends->new($mock);
|
||||
|
||||
my $mocked_id;
|
||||
my $mocked_url;
|
||||
|
||||
my @ns_path = map { $_ . '::' } split /::/, ref $mock;
|
||||
my $ns_last = pop @ns_path;
|
||||
my $ns_root = do {
|
||||
no strict 'refs';
|
||||
\%{ join('', @ns_path) };
|
||||
};
|
||||
|
||||
my $stash = Package::Stash->new(ref $mock);
|
||||
$stash->add_package_symbol('&DESTROY', sub {
|
||||
my $self = shift;
|
||||
$self->unmock_id;
|
||||
$self->unmock_url;
|
||||
|
||||
if ( my $super = $self->can('SUPER::DESTROY') ) {
|
||||
$self->$super;
|
||||
}
|
||||
|
||||
undef $self;
|
||||
|
||||
# remove our namespace
|
||||
delete $ns_root->{ $ns_last };
|
||||
});
|
||||
$stash->add_package_symbol('&mock_id', sub {
|
||||
my $self = shift;
|
||||
$self->unmock_id;
|
||||
$mocked_id = shift;
|
||||
$CLASS->mock_id($mocked_id, $self);
|
||||
|
||||
$self->set_always('assetId', $mocked_id);
|
||||
$self->set_always('getId', $mocked_id);
|
||||
|
||||
return $self;
|
||||
});
|
||||
$stash->add_package_symbol('&unmock_id', sub {
|
||||
my $self = shift;
|
||||
if ($mocked_id) {
|
||||
$CLASS->unmock_id($mocked_id);
|
||||
}
|
||||
return $self;
|
||||
});
|
||||
$stash->add_package_symbol('&mock_url', sub {
|
||||
my $self = shift;
|
||||
$self->unmock_url;
|
||||
$mocked_url = shift;
|
||||
$CLASS->mock_url($mocked_url, $self);
|
||||
|
||||
$self->set_always('url', $mocked_url);
|
||||
|
||||
return $self;
|
||||
});
|
||||
$stash->add_package_symbol('&unmock_url', sub {
|
||||
my $self = shift;
|
||||
if ($mocked_url) {
|
||||
$CLASS->unmock_url($mocked_url);
|
||||
}
|
||||
return $self;
|
||||
});
|
||||
|
||||
return $mock;
|
||||
}
|
||||
|
||||
sub mock_id {
|
||||
my $class = shift;
|
||||
my $id = shift;
|
||||
my $asset = shift;
|
||||
$mocked_assetIds{$id} = $asset;
|
||||
weaken $mocked_assetIds{$id};
|
||||
return;
|
||||
}
|
||||
|
||||
sub unmock_id {
|
||||
my $class = shift;
|
||||
my $id = shift;
|
||||
delete $mocked_assetIds{$id};
|
||||
return;
|
||||
}
|
||||
|
||||
sub mock_url {
|
||||
my $class = shift;
|
||||
my $url = shift;
|
||||
my $asset = shift;
|
||||
$mocked_assetUrls{$url} = $asset;
|
||||
weaken $mocked_assetUrls{$url};
|
||||
return;
|
||||
}
|
||||
|
||||
sub unmock_url {
|
||||
my $class = shift;
|
||||
my $url = shift;
|
||||
delete $mocked_assetUrls{$url};
|
||||
return;
|
||||
}
|
||||
|
||||
1;
|
||||
Loading…
Add table
Add a link
Reference in a new issue