oqapi/webgui
2
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

some WebGUI::Test cleanups

Browse source
This commit is contained in:
Graham Knop 2010-06-09 07:03:49 -05:00
parent 6b1c3c8890
commit 883b145c44
1 changed files with 27 additions and 16 deletions
Download patch file Download diff file Expand all files Collapse all files

43
t/lib/WebGUI/Test.pm
View file

@ -39,6 +39,7 @@ use List::MoreUtils qw( any );
use Carp qw( carp croak ); use Carp qw( carp croak );
use JSON qw( from_json to_json ); use JSON qw( from_json to_json );
use Scope::Guard; use Scope::Guard;
use Try::Tiny;
use WebGUI::Paths -inc; use WebGUI::Paths -inc;
our $WEBGUI_TEST_ROOT = File::Spec->catdir( our $WEBGUI_TEST_ROOT = File::Spec->catdir(
@ -141,8 +142,6 @@ sub newSession {
my $noCleanup = shift; my $noCleanup = shift;
require WebGUI::Session; require WebGUI::Session;
my $session = WebGUI::Session->open( $CLASS->config, newEnv() ); my $session = WebGUI::Session->open( $CLASS->config, newEnv() );
# my $pseudoRequest = WebGUI::PseudoRequest->new;
# $session->{_request} = $pseudoRequest;
if ( ! $noCleanup ) { if ( ! $noCleanup ) {
$CLASS->addToCleanup($session); $CLASS->addToCleanup($session);
} }
@ -154,11 +153,24 @@ sub newEnv {
require HTTP::Message::PSGI; require HTTP::Message::PSGI;
require HTTP::Request::Common; require HTTP::Request::Common;
my $config = $CLASS->config; my $config = $CLASS->config;
my $url = 'http://' . $config->get('sitename'); my $url = 'http://' . $config->get('sitename')->[0];
my $env = HTTP::Request->new( $form ? ( POST => $url, [ %$form ] ) : ( GET => $url ) )->to_psgi; my $env = HTTP::Request->new( $form ? ( POST => $url, [ %$form ] ) : ( GET => $url ) )->to_psgi;
return $env; return $env;
} }
sub clientTest (&) {
my $client = shift;
local $ENV{WEBGUI_CONFIG} = $CLASS->file;
my $test_psgi = Plack::Util::load_psgi(
$CLASS->config->get('psgiFile')
|| WebGUI::Paths->defaultPSGI,
);
Plack::Test::test_psgi(
app => $test_psgi,
client => $client,
);
}
#---------------------------------------------------------------------------- #----------------------------------------------------------------------------
=head2 mockAssetId ( $assetId, $object ) =head2 mockAssetId ( $assetId, $object )
@ -419,7 +431,6 @@ sub getPage {
# Return the page's output # Return the page's output
return join '', @{$session->response->body}; return join '', @{$session->response->body};
} }
#---------------------------------------------------------------------------- #----------------------------------------------------------------------------
@ -841,7 +852,14 @@ Example call:
}, },
'SQL' => sub { 'SQL' => sub {
my (undef, $sql) = @_; my (undef, $sql) = @_;
return $CLASS->session->db->dbh->prepare($sql); my $db = $CLASS->session->db;
my @params;
if ( ref $sql ) {
( $sql, @params ) = @$sql;
}
return sub {
$db->do( $sql, {}, @params );
}
}, },
); );
@ -922,7 +940,9 @@ Example call:
'CODE' => sub { 'CODE' => sub {
(shift)->(); (shift)->();
}, },
'SQL' => 'execute', 'SQL' => sub {
(shift)->();
},
); );
sub cleanupGuard { sub cleanupGuard {
@ -1007,7 +1027,7 @@ This is a class method.
my @guarded; my @guarded;
sub addToCleanup { sub addToCleanup {
shift shift
if eval { $_[0]->isa($CLASS) }; if try { $_[0]->isa($CLASS) };
push @guarded, cleanupGuard(@_); push @guarded, cleanupGuard(@_);
} }
@ -1030,13 +1050,4 @@ sub cleanup {
} }
} }
#----------------------------------------------------------------------------
=head1 BUGS
When trying to load the APR module, perl invariably throws an Out Of Memory
error. For this reason, getPage disables header processing.
=cut
1; 1;