1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
|
# $Id: TestToolkit.pm 1908 2023-03-15 07:28:50Z willem $ -*-perl-*-
package TestToolkit;
=head1 NAME
TestToolkit - Convenient tools to simplify test script construction.
=cut
use strict;
use warnings;
use Carp;
use Test::Builder;
use Test::More;
use base qw(Exporter);
our @EXPORT = qw(exception noexception NonFatalBegin NonFatalEnd);
=head1 exception noexception
[no]exception( 'test description', sub { code fragment } );
Executes the supplied code fragment and reports a raised exception or
warning using the Test::More ok() mechanism.
=cut
sub exception {
my ( $name, $code ) = @_;
my $exception = _execute($code);
my $boolean = $exception ? 1 : 0;
my $tb = Test::Builder->new;
return $tb->ok( $boolean, "$name\t[$exception]" );
}
sub noexception {
my ( $name, $code ) = @_;
my $exception = _execute($code);
my $boolean = $exception ? 0 : 1;
my $tb = Test::Builder->new;
return $tb->ok( $boolean, $exception ? "$name\t[$exception]" : $name );
}
sub _execute {
my $code = shift;
my @warning;
local $SIG{__WARN__} = sub { push @warning, "@_" };
local ( $@, $!, $SIG{__DIE__} ); ## isolate eval
eval {
&$code;
croak shift(@warning) if @warning;
};
my ($exception) = split /[\r\n]+/, "$@\n";
return $exception;
}
########################################
#
# Test::More test functions all eventually call Test::Builder::ok
# (on the (singular) builder instance) to report the status.
# The NonFatal package defines a subclass derived from Test::Builder,
# with a redefined ok method that overrides the completion status
# seen by the test harness.
#
# Note: Modified behaviour is enabled by the 't/online.nonfatal' file.
#
=head1 NonFatalBegin NonFatalEnd
Tests that are between these functions will always appear to succeed.
The failure report itself is not suppressed.
=cut
sub NonFatalBegin { return bless Test::Builder->new, qw(NonFatal) }
sub NonFatalEnd { return bless Test::Builder->new, qw(Test::Builder) }
package NonFatal;
use base qw(Test::Builder);
my $enabled = eval { -e 't/online.nonfatal' };
my @failed;
sub ok {
my ( $self, $test, @name ) = @_;
return $self->SUPER::ok( $test, @name ) if $test;
if ($enabled) {
my $number = $self->current_test + 1;
push @failed, join( "\t", $number, @name );
@name = "NOT OK (tolerating failure) @name";
}
return $self->SUPER::ok( $enabled, @name );
}
END {
my $n = scalar(@failed) || return;
my $s = ( $n == 1 ) ? '' : 's';
my $tb = __PACKAGE__->SUPER::new();
$tb->diag( join "\n", "\nDisregarding $n failed sub-test$s", @failed );
}
1;
__END__
|
