File Coverage

inc/Test/NoWarnings.pm
Criterion Covered Total %
statement 58 68 85.2
branch 5 10 50.0
condition 1 2 50.0
subroutine 16 18 88.8
pod 3 6 50.0
total 83 104 79.8


line stmt bran cond sub pod time code
1             package Test::NoWarnings;
2              
3 77     77   176655 use 5.006;
  77         245  
4 77     77   413 use strict;
  77         130  
  77         1565  
5 77     77   343 use warnings;
  77         120  
  77         2064  
6              
7 77     77   423 use Carp ();
  77         131  
  77         1159  
8 77     77   332 use Exporter ();
  77         160  
  77         1391  
9 77     77   406 use Test::Builder ();
  77         106  
  77         1170  
10 77     77   25170 use Test::NoWarnings::Warning ();
  77         148  
  77         1787  
11              
12 77     77   354 use vars qw( $VERSION @EXPORT_OK @ISA $do_end_test );
  77         106  
  77         5677  
13             BEGIN {
14 77     77   204 $VERSION = '1.02';
15 77         1175 @ISA = 'Exporter';
16 77         286 @EXPORT_OK = qw(
17             clear_warnings had_no_warnings warnings
18             );
19              
20             # Do we add the warning test at the end?
21 77         38148 $do_end_test = 0;
22             }
23              
24             my $TEST = Test::Builder->new;
25             my $PID = $$;
26             my @WARNINGS = ();
27              
28             $SIG{__WARN__} = make_catcher(\@WARNINGS);
29              
30             sub import {
31 77     77   461 $do_end_test = 1;
32 77         102637 goto &Exporter::import;
33             }
34              
35             # the END block must be after the "use Test::Builder" to make sure it runs
36             # before Test::Builder's end block
37             # only run the test if there have been other tests
38             END {
39 77 50   77   4801525 had_no_warnings() if $do_end_test;
40             }
41              
42             sub make_warning {
43 6     6 0 15 local $SIG{__WARN__};
44              
45 6         9 my $msg = shift;
46 6         19 my $warning = Test::NoWarnings::Warning->new;
47              
48 6         14 $warning->setMessage($msg);
49 6         15 $warning->fillTest($TEST);
50 6         13 $warning->fillTrace(__PACKAGE__);
51              
52 6         9 $Carp::Internal{__PACKAGE__.""}++;
53 6         8 local $Carp::CarpLevel = $Carp::CarpLevel + 1;
54 6         15 $warning->fillCarp($msg);
55 6         8 $Carp::Internal{__PACKAGE__.""}--;
56              
57 6         18 return $warning;
58             }
59              
60             # this make a subroutine which can be used in $SIG{__WARN__}
61             # it takes one argument, a ref to an array
62             # it will push the details of the warning onto the end of the array.
63             sub make_catcher {
64 77     77 0 102 my $array = shift;
65              
66             return sub {
67 6     6   267 my $msg = shift;
68              
69 6         28 $Carp::Internal{__PACKAGE__.""}++;
70 6         17 push(@$array, make_warning($msg));
71 6         14 $Carp::Internal{__PACKAGE__.""}--;
72              
73 6         42 return $msg;
74 77         542 };
75             }
76              
77             sub had_no_warnings {
78 79 100   79 1 2590 return 0 if $$ != $PID;
79              
80 77         411 local $SIG{__WARN__};
81 77   50     709 my $name = shift || "no warnings";
82              
83 77         241 my $ok;
84             my $diag;
85 77 50       378 if ( @WARNINGS == 0 ) {
86 77         192 $ok = 1;
87             } else {
88 0         0 $ok = 0;
89 0         0 $diag = "There were ".@WARNINGS." warning(s)\n";
90 0         0 $diag .= join "----------\n", map { $_->toString } @WARNINGS;
  0         0  
91             }
92              
93 77 50       390 $TEST->ok($ok, $name) || $TEST->diag($diag);
94              
95 77         24638 return $ok;
96             }
97              
98             sub clear_warnings {
99 2     2 1 472 local $SIG{__WARN__};
100 2         218 @WARNINGS = ();
101             }
102              
103             sub warnings {
104 0     0 1   local $SIG{__WARN__};
105 0           return @WARNINGS;
106             }
107              
108             sub builder {
109 0     0 0   local $SIG{__WARN__};
110 0 0         if ( @_ ) {
111 0           $TEST = shift;
112             }
113 0           return $TEST;
114             }
115              
116             1;
117              
118             __END__