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
|
package OurTester;
use strict;
use warnings;
use Carp 'croak';
BEGIN {
unless ( $INC{'Test/Most.pm'} ) {
croak ("Test::Most must be loaded before ".__PACKAGE__);
}
}
use Exporter;
our @ISA = 'Exporter';
our ( $DIED, $BAILED );
our @EXPORT_OK = qw($DIED $BAILED dies bails);
use Test::Builder;
my $BUILDER = Test::Builder->new;
sub _set_die {
_set_test_failure_handler( sub { $DIED = 1 } );
}
sub _set_bail {
_set_test_failure_handler( sub { $BAILED = 1 } );
}
#
# This is like the normal override for Test::More::ok, but we need to check
# the actual value of of the test status, regardless of whether or not it's a
# TODO test.
#
sub _set_test_failure_handler {
my $action = shift;
my $ok = \&Test::Builder::ok;
no warnings 'redefine';
*Test::Builder::ok = sub {
local $Test::Builder::Level = $Test::Builder::Level + 1;
my $builder = $_[0];
if ( $builder->{TEST_MOST_test_failed} ) {
$builder->{TEST_MOST_test_failed} = 0;
$action->($builder);
}
$builder->{TEST_MOST_test_failed} = 0;
my $result = $ok->(@_);
# Not a fun interface
$builder->{TEST_MOST_test_failed} = !( $builder->details )[-1]->{actual_ok};
return $result;
};
}
sub dies(&;$) {
my ( $sub, $message ) = @_;
_die_or_bail($sub, \&_set_die, $message, \$DIED);
}
sub bails(&;$) {
my ( $sub, $message ) = @_;
_die_or_bail($sub, \&_set_bail, $message, \$BAILED);
}
sub _die_or_bail {
my ($sub, $internal_sub, $message, $die_or_bail) = @_;
$internal_sub->();
$BUILDER->todo_start('Planned failure');
# ignore the error messages as they will be confusing.
$BUILDER->no_diag(1);
$sub->();
$BUILDER->no_diag(0);
$BUILDER->todo_end;
Test::More::ok 1, 'arguments are evaluated *before* ok()';
Test::More::ok $$die_or_bail, $message;
$$die_or_bail = 0;
}
1;
|
