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
|
#!perl -T
# -*-mode:cperl-*-
use Test::More;
eval "use Test::Pod::Coverage 1.04";
plan skip_all => "Test::Pod::Coverage 1.04 required for testing POD coverage" if $@;
{
package MyPodCoverage;
our @ISA = 'Pod::Coverage';
my $package;
sub _CvGV {
my $self = shift;
my $owner = $self->SUPER::_CvGV(@_);
return $owner unless my $p = $self->{package}; # guard ...
$owner =~ s/^\*Test::Trap::Builder/*$p/; # evil!
return $owner;
}
$INC{'MyPodCoverage.pm'} = 1; # pretend we're loaded :)
# In newer Pod::Coverage, _CvGV above is not used, and no interface
# is exposed to deal with this! Bad Pod::Coverage!
# All I can think of doing, is mess with B::GV::GvFLAGS instead:
my $old = \&B::GV::GvFLAGS;
my $imported_cv = eval { B::GVf_IMPORTED_CV() } || 0x80;
no warnings 'redefine';
*B::GV::GvFLAGS = sub { # truly evil!
my $r = $old->(@_);
$r &= ~$imported_cv if $_[0]->FILE =~ m,/blib/lib/Test/Trap/Builder,;
return $r;
};
}
my $layer =
qr/ ^ layer:
(?: raw
| die
| exit
| flow
| stdout
| stderr
| warn
| default
| list
| scalar
| void
| output
| on_fail
) $
/x;
my $accessor =
qr/ (?: leaveby
| exit
| die
| stdout
| stderr
| wantarray
| return
| warn
| list
| scalar
| void
)
/x;
my $did = qr/ ^ did _ $accessor $ /x;
my $test =
qr/ ^ $accessor _
(?: ok
| nok
| is
| isnt
| isa_ok
| like
| unlike
| cmp_ok
| is_deeply
) $
/x;
my $more =
qr/ ^
(?: Exception
| Next
| Prop
| Run
| Teardown
| TestAccessor
| TestFailure
) $
/x;
all_pod_coverage_ok({ trustme => [$layer, $did, $test, $more],
coverage_class => 'MyPodCoverage',
});
|
