1#  You may distribute under the terms of either the GNU General Public License
2#  or the Artistic License (the same terms as Perl itself)
3#
4#  (C) Paul Evans, 2020 -- leonerd@leonerd.org.uk
5
6package Test::Metrics::Any;
7
8use strict;
9use warnings;
10use base qw( Test::Builder::Module );
11
12use Metrics::Any::Adapter 'Test';
13use Metrics::Any::Adapter::Test; # Eager load
14
15our $VERSION = '0.01';
16
17our @EXPORT = qw(
18   is_metrics
19   is_metrics_from
20);
21
22=head1 NAME
23
24C<Test::Metrics::Any> - assert that code produces metrics via L<Metrics::Any>
25
26=head1 SYNOPSIS
27
28   use Test::More;
29   use Test::Metrics::Any;
30
31   use Module::Under::Test;
32
33   is_metrics_from(
34      sub { Module::Under::Test::do_a_thing for 1 .. 5 },
35      {
36         things_done => 5,
37         time_taken => Test::Metrics::Any::positive,
38      },
39      'do_a_thing reported some metrics'
40   );
41
42   done_testing;
43
44=head1 DESCRIPTION
45
46This test module helps write unit tests which assert that the code under test
47reports metrics via L<Metrics::Any>.
48
49Loading this module automatically sets the L<Metrics::Any::Adapter> type to
50C<Test>.
51
52=cut
53
54=head1 FUNCTIONS
55
56=cut
57
58=head2 is_metrics
59
60   is_metrics( \%metrics, $name )
61
62Asserts that the current value of every metric named in the given hash
63reference is set to the value provided. Values can either be given as exact
64numbers, or by one of the match functions mentioned in L</PREDICATES>.
65
66Key names in the given hash should match the name format used by
67L<Metrics::Any::Adapter::Test>. Name components are joined by underscores, and
68any label tags are appended with spaces, as C<name:value>.
69
70   {
71      "a_basic_metric"               => 123,
72      "a_labelled_metric label:here" => 456,
73   }
74
75This function only checks the values of metrics actually mentioned in the hash
76given as its argument. It is not a failure for more metrics to have been
77reported by the code under test than are mentioned in the hash. This helps to
78ensure that new metrics added in code do not break existing tests that weren't
79set up to expect them.
80
81=cut
82
83sub is_metrics
84{
85   my ( $expect, $testname ) = @_;
86   my $tb = __PACKAGE__->builder;
87
88   my %got = map { ( split m/\s*=\s*/, $_ )[0,1] } split m/\n/, Metrics::Any::Adapter::Test->metrics;
89
90   foreach my $name ( sort keys %$expect ) {
91      my $expectval = $expect->{$name};
92
93      my $gotval = $got{$name};
94      unless( defined $gotval ) {
95         my $ret = $tb->ok( 0, $testname );
96         $tb->diag( "Expected a metric called '$name' but didn't find one" );
97         return $ret;
98      }
99
100      if( ref $expectval eq "Test::Metrics::Any::_predicate" ) {
101         unless( $expectval->check( $gotval ) ) {
102            my $ret = $tb->ok( 0, $testname );
103            $tb->diag( "Expected metric '$name' to be ${\$expectval->message} but got $gotval" );
104            return $ret;
105         }
106      }
107      else {
108         unless( $gotval == $expectval ) {
109            my $ret = $tb->ok( 0, $testname );
110            $tb->diag( "Expected metric '$name' to be $expectval but got $gotval" );
111            return $ret;
112         }
113      }
114   }
115
116   return $tb->ok( 1, $testname );
117}
118
119=head2 is_metrics_from
120
121   is_metrics_from( $code, \%metrics, $name )
122
123Asserts the value of metrics reported by running the given piece of code.
124
125The metrics in the test adapter are cleared, then the code is invoked, then
126any metrics are checked in the same manner as L</is_metrics>.
127
128=cut
129
130sub is_metrics_from(&@)
131{
132   my ( $code, $expect, $testname ) = @_;
133
134   Metrics::Any::Adapter::Test->clear;
135
136   $code->();
137
138   local $Test::Builder::Level = $Test::Builder::Level + 1;
139   return is_metrics( $expect, $testname );
140}
141
142=head1 PREDICATES
143
144As an alternative to expecting exact values for metrics, the following test
145functions can be provided instead to assert that the metric is behaving
146sensibly without needing to be an exact value. This could be useful for
147example when the exact number of bytes or timing measures can vary between
148test runs or platforms.
149
150These predicates are not exported but must be invoked fully-qualified.
151
152=cut
153
154sub predicate { return bless [ @_ ], "Test::Metrics::Any::_predicate" }
155{
156   package Test::Metrics::Any::_predicate;
157   sub check   { my $self = shift; $self->[1]->( shift ) }
158   sub message { my $self = shift; $self->[0] }
159}
160
161=head2 positive
162
163   metric => Test::Metrics::Any::positive
164
165Asserts that the number is greater than zero. It must not be zero.
166
167=cut
168
169sub positive { predicate positive => sub { shift > 0 } }
170
171=head2 at_least
172
173   metric => Test::Metrics::Any::at_least( $n )
174
175Asserts that the number at least that given - it can be equal or greater.
176
177=cut
178
179sub at_least { my ($n) = @_; predicate "at least $n" => sub { shift >= $n } }
180
181=head2 greater_than
182
183   metric => Test::Metrics::Any::greater_than( $n )
184
185Asserts that the number is greater than that given - it must not be equal.
186
187=cut
188
189sub greater_than { my ($n) = @_; predicate "greater than $n" => sub { shift > $n } }
190
191=head1 AUTHOR
192
193Paul Evans <leonerd@leonerd.org.uk>
194
195=cut
196
1970x55AA;
198