merging commerce branch back into head

t/lib/WebGUI/TestException.pm

@@ -0,0 +1,123 @@
+package WebGUI::TestException;
+
+use strict;
+
+use Test::Builder;
+use WebGUI::Exception;
+use Sub::Uplevel qw( uplevel );
+
+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;
+