File Coverage

blib/lib/Log/Any/Adapter/Test.pm
Criterion Covered Total %
statement 72 111 64.8
branch 9 24 37.5
condition 6 20 30.0
subroutine 20 25 80.0
pod 0 9 0.0
total 107 189 56.6


line stmt bran cond sub pod time code
1 11     11   209 use 5.008001;
  11         44  
2 11     11   65 use strict;
  11         21  
  11         257  
3 11     11   53 use warnings;
  11         33  
  11         681  
4              
5             package Log::Any::Adapter::Test;
6              
7             our $VERSION = '1.715';
8              
9 11     11   75 use Log::Any::Adapter::Util qw/dump_one_line/;
  11         27  
  11         724  
10 11     11   77 use Test::Builder;
  11         21  
  11         314  
11              
12 11     11   2791 use Log::Any::Adapter::Base;
  11         24  
  11         1794  
13             our @ISA = qw/Log::Any::Adapter::Base/;
14              
15             my $tb = Test::Builder->new();
16             my @msgs;
17              
18             # Ignore arguments for the original adapter if we're overriding, but recover
19             # category from argument list; this depends on category => $category being put
20             # at the end of the list in Log::Any::Manager. If not overriding, allow
21             # arguments as usual.
22              
23             sub new {
24 19     19 0 39 my $class = shift;
25 19 100 66     93 if ( defined $Log::Any::OverrideDefaultAdapterClass
26             && $Log::Any::OverrideDefaultAdapterClass eq __PACKAGE__ )
27             {
28 8         18 my $category = pop @_;
29 8         47 return $class->SUPER::new( category => $category );
30             }
31             else {
32 11         66 return $class->SUPER::new(@_);
33             }
34             }
35              
36             # All detection methods return true
37             #
38             foreach my $method ( Log::Any::Adapter::Util::detection_methods() ) {
39 11     11   86 no strict 'refs';
  11         43  
  11         997  
40 55     55   177 *{$method} = sub { 1 };
41             }
42              
43             # All logging methods push onto msgs array
44             #
45             foreach my $method ( Log::Any::Adapter::Util::logging_methods() ) {
46 11     11   81 no strict 'refs';
  11         32  
  11         14036  
47             *{$method} = sub {
48 30     30   80 my ( $self, $msg ) = @_;
49             push(
50             @msgs,
51             {
52             message => $msg,
53             level => $method,
54             category => $self->{category}
55             }
56 30         168 );
57             };
58             }
59              
60             # Testing methods below
61             #
62              
63             sub msgs {
64 61     61 0 119 my $self = shift;
65              
66 61         197 return \@msgs;
67             }
68              
69             sub clear {
70 9     9 0 18 my ($self) = @_;
71              
72 9         208 @msgs = ();
73             }
74              
75             sub contains_ok {
76 21     21 0 52 my ( $self, $regex, $test_name ) = @_;
77              
78 21         44 local $Test::Builder::Level = $Test::Builder::Level + 1;
79              
80 21   66     54 $test_name ||= "log contains '$regex'";
81             my $found =
82 21     20   76 _first_index( sub { $_->{message} =~ /$regex/ }, @{ $self->msgs } );
  20         189  
  21         50  
83 21 100       114 if ( $found != -1 ) {
84 20         34 splice( @{ $self->msgs }, $found, 1 );
  20         52  
85 20         97 $tb->ok( 1, $test_name );
86             }
87             else {
88 1         6 $tb->ok( 0, $test_name );
89 1         2029 $tb->diag( "could not find message matching $regex" );
90 1         402 _diag_msgs();
91             }
92             }
93              
94             sub category_contains_ok {
95 5     5 0 12 my ( $self, $category, $regex, $test_name ) = @_;
96              
97 5         11 local $Test::Builder::Level = $Test::Builder::Level + 1;
98              
99 5   33     13 $test_name ||= "log for $category contains '$regex'";
100             my $found =
101             _first_index(
102 5 50   5   67 sub { $_->{category} eq $category && $_->{message} =~ /$regex/ },
103 5         22 @{ $self->msgs } );
  5         12  
104 5 50       42 if ( $found != -1 ) {
105 5         7 splice( @{ $self->msgs }, $found, 1 );
  5         12  
106 5         22 $tb->ok( 1, $test_name );
107             }
108             else {
109 0         0 $tb->ok( 0, $test_name );
110 0         0 $tb->diag( "could not find $category message matching $regex" );
111 0         0 _diag_msgs();
112             }
113             }
114              
115             sub does_not_contain_ok {
116 0     0 0 0 my ( $self, $regex, $test_name ) = @_;
117              
118 0         0 local $Test::Builder::Level = $Test::Builder::Level + 1;
119              
120 0   0     0 $test_name ||= "log does not contain '$regex'";
121             my $found =
122 0     0   0 _first_index( sub { $_->{message} =~ /$regex/ }, @{ $self->msgs } );
  0         0  
  0         0  
123 0 0       0 if ( $found != -1 ) {
124 0         0 $tb->ok( 0, $test_name );
125 0         0 $tb->diag( "found message matching $regex: " . $self->msgs->[$found]->{message} );
126             }
127             else {
128 0         0 $tb->ok( 1, $test_name );
129             }
130             }
131              
132             sub category_does_not_contain_ok {
133 0     0 0 0 my ( $self, $category, $regex, $test_name ) = @_;
134              
135 0         0 local $Test::Builder::Level = $Test::Builder::Level + 1;
136              
137 0   0     0 $test_name ||= "log for $category contains '$regex'";
138             my $found =
139             _first_index(
140 0 0   0   0 sub { $_->{category} eq $category && $_->{message} =~ /$regex/ },
141 0         0 @{ $self->msgs } );
  0         0  
142 0 0       0 if ( $found != -1 ) {
143 0         0 $tb->ok( 0, $test_name );
144 0         0 $tb->diag( "found $category message matching $regex: "
145             . $self->msgs->[$found] );
146             }
147             else {
148 0         0 $tb->ok( 1, $test_name );
149             }
150             }
151              
152             sub empty_ok {
153 3     3 0 14 my ( $self, $test_name ) = @_;
154              
155 3         10 local $Test::Builder::Level = $Test::Builder::Level + 1;
156              
157 3   50     22 $test_name ||= "log is empty";
158 3 50       12 if ( !@{ $self->msgs } ) {
  3         14  
159 3         14 $tb->ok( 1, $test_name );
160             }
161             else {
162 0         0 $tb->ok( 0, $test_name );
163 0         0 $tb->diag( "log is not empty" );
164 0         0 _diag_msgs();
165 0         0 $self->clear();
166             }
167             }
168              
169             sub contains_only_ok {
170 0     0 0 0 my ( $self, $regex, $test_name ) = @_;
171              
172 0         0 local $Test::Builder::Level = $Test::Builder::Level + 1;
173              
174 0   0     0 $test_name ||= "log contains only '$regex'";
175 0         0 my $count = scalar( @{ $self->msgs } );
  0         0  
176 0 0       0 if ( $count == 1 ) {
177 0         0 local $Test::Builder::Level = $Test::Builder::Level + 1;
178 0         0 $self->contains_ok( $regex, $test_name );
179             }
180             else {
181 0         0 $tb->ok( 0, $test_name );
182 0         0 _diag_msgs();
183             }
184             }
185              
186             sub _diag_msgs {
187 1     1   4 my $count = @msgs;
188 1 50       4 if ( ! $count ) {
189 1         7 $tb->diag("log contains no messages");
190             }
191             else {
192 0 0       0 $tb->diag("log contains $count message" . ( $count > 1 ? "s:" : ":"));
193 0         0 $tb->diag(dump_one_line($_)) for @msgs;
194             }
195             }
196              
197             sub _first_index {
198 26     26   48 my $f = shift;
199 26         90 for my $i ( 0 .. $#_ ) {
200 25         67 local *_ = \$_[$i];
201 25 50       52 return $i if $f->();
202             }
203 1         3 return -1;
204             }
205              
206              
207             1;
208              
209             __END__