124 lines
3.4 KiB
Perl
124 lines
3.4 KiB
Perl
package WebGUI::TestException;
|
|
|
|
use strict;
|
|
|
|
use Test::Builder;
|
|
use WebGUI::Exception;
|
|
use Sub::Uplevel qw( uplevel );
|
|
use Exporter qw(import);
|
|
|
|
our @EXPORT = qw( throws_deeply );
|
|
|
|
=head1 NAME
|
|
|
|
Package WebGUI::TestException
|
|
|
|
=head1 DESCRIPTION
|
|
|
|
This module provides a convenient way to test for thrown exceptions. The idea is based on Test::Exception, which
|
|
does provide a means to test for a specific exception class, but cannot test attributes of that class, which is
|
|
necessary in the WebGUI test suite. This module can do that.
|
|
|
|
=head1 CAVEATS
|
|
|
|
This module uses Sub::Uplevel. In Test::Exception some hocus pocus is being done with the caller() function. The
|
|
functions _quiet_caller and _try_as_caller are directly copied from Test::Exception. I do not know why this
|
|
hocuspocus is being in that module however, since doing 'eval { uplevel 1, $codeRef }' seems to work too. On my
|
|
platform at least =). For the time being, I leave those subs in here so that they may be used. They are commented
|
|
out by default, though.
|
|
=cut
|
|
|
|
#----------------------------------------------------------------------------
|
|
sub _quiet_caller (;$) { ## no critic Prototypes
|
|
my $height = $_[0];
|
|
$height++;
|
|
if( wantarray and !@_ ) {
|
|
return (CORE::caller($height))[0..2];
|
|
}
|
|
else {
|
|
return CORE::caller($height);
|
|
}
|
|
}
|
|
|
|
#----------------------------------------------------------------------------
|
|
sub _try_as_caller {
|
|
my $coderef = shift;
|
|
|
|
# local works here because Sub::Uplevel has already overridden caller
|
|
local *CORE::GLOBAL::caller;
|
|
{ no warnings 'redefine'; *CORE::GLOBAL::caller = \&_quiet_caller; }
|
|
|
|
eval { uplevel 3, $coderef };
|
|
return $@;
|
|
};
|
|
|
|
=head2 throws_deeply ( $codeRef, $expectClass, $fields, $message )
|
|
|
|
Executes the code ref and verifies it throws an exception of the given class with the given fields.
|
|
|
|
=head3 $codeRef
|
|
|
|
The code ref containing the code to be evalled.
|
|
|
|
=head3 $expectClass
|
|
|
|
The class name the thrown exception should have.
|
|
|
|
=head3 $fields
|
|
|
|
Hashref containg the exception fields and their expected values.
|
|
|
|
=head3 $message
|
|
|
|
The message that should be displayed by prove for this test.
|
|
|
|
=cut
|
|
|
|
#----------------------------------------------------------------------------
|
|
sub throws_deeply {
|
|
my $evalBlock = shift;
|
|
my $expectClass = shift;
|
|
my $fields = shift;
|
|
my $message = shift;
|
|
my $testBuilder = Test::Builder->new;
|
|
|
|
# Dunno why uplevel 1 might not work and why caller is redefined.
|
|
# Copied _try_as_caller and _quiet_caller are from Test::Exception.
|
|
# Uplevel 1 seems to work though.
|
|
#_try_as_caller( $evalBlock );
|
|
eval { uplevel 1, $evalBlock };
|
|
|
|
my $e = Exception::Class->caught();
|
|
my $gotClass = ref $e;
|
|
|
|
# Check class
|
|
unless ($gotClass eq $expectClass) {
|
|
$testBuilder->ok(0, $message);
|
|
$testBuilder->diag("Wrong class:\n\texpected : '$expectClass'\n\t got : '$gotClass'");
|
|
|
|
return 0;
|
|
}
|
|
|
|
# Check fields
|
|
my $errors;
|
|
foreach (keys %$fields) {
|
|
my $result = $e->$_;
|
|
|
|
unless ( $result eq $fields->{$_} ) {
|
|
$errors .= "'$_' => \n\texpected : '".$fields->{$_}."'\n\t got : '$result'\n";
|
|
}
|
|
}
|
|
if ($errors) {
|
|
$testBuilder->ok(0, $message);
|
|
$testBuilder->diag("Fields do not match:\n$errors");
|
|
|
|
return 0;
|
|
}
|
|
|
|
# Test passed.
|
|
$testBuilder->ok(1, $message);
|
|
return 1;
|
|
}
|
|
|
|
1;
|
|
|