local-lib5/lib/perl5/Test/SubCalls.pm

   1 package Test::SubCalls;
   2
   3 =pod
   4
   5 =head1 NAME
   6
   7 Test::SubCalls - Track the number of times subs are called
   8
   9 =head1 SYNOPSIS
  10
  11   use Test::SubCalls;
  12
  13   # Start tracking calls to a named sub
  14   sub_track( 'Foo::foo' );
  15
  16   # Run some test code
  17   ...
  18
  19   # Test that some sub deep in the codebase was called
  20   # a specific number of times.
  21   sub_calls( 'Foo::foo', 5 );
  22   sub_calls( 'Foo::foo', 5, 'Use a custom test message' );
  23
  24   # Reset the counts for one or all subs
  25   sub_reset( 'Foo::foo' );
  26   sub_reset_all();
  27
  28 =head1 DESCRIPTION
  29
  30 There are a number of different situations (like testing caching code)
  31 where you want to want to do a number of tests, and then verify that
  32 some underlying subroutine deep within the code was called a specific
  33 number of times.
  34
  35 This module provides a number of functions for doing testing in this way
  36 in association with your normal L<Test::More> (or similar) test scripts.
  37
  38 =head1 FUNCTIONS
  39
  40 In the nature of test modules, all functions are exported by default.
  41
  42 =cut
  43
  44 use 5.006;
  45 use strict;
  46 use File::Spec    0.80 ();
  47 use Test::More    0.42 ();
  48 use Hook::LexWrap 0.20 ();
  49 use Exporter           ();
  50 use Test::Builder      ();
  51
  52 use vars qw{$VERSION @ISA @EXPORT};
  53 BEGIN {
  54         $VERSION = '1.09';
  55         @ISA     = 'Exporter';
  56         @EXPORT  = qw{sub_track sub_calls sub_reset sub_reset_all};
  57 }
  58
  59 my $Test = Test::Builder->new;
  60
  61 my %CALLS = ();
  62
  63
  64
  65
  66
  67 #####################################################################
  68 # Test::SubCalls Functions
  69
  70 =pod
  71
  72 =head2 sub_track $subname
  73
  74 The C<sub_track> function creates a new call tracker for a named function.
  75
  76 The sub to track must be provided by name, references to the function
  77 itself are insufficient.
  78
  79 Returns true if added, or dies on error.
  80
  81 =cut
  82
  83 sub sub_track {
  84         # Check the sub name is valid
  85         my $subname = shift;
  86         SCOPE: {
  87                 no strict 'refs';
  88                 unless ( defined *{"$subname"}{CODE} ) {
  89                         die "Test::SubCalls::sub_track : The sub '$subname' does not exist";
  90                 }
  91                 if ( defined $CALLS{$subname} ) {
  92                         die "Test::SubCalls::sub_track : Cannot add duplicate tracker for '$subname'";
  93                 }
  94         }
  95
  96         # Initialise the count
  97         $CALLS{$subname} = 0;
  98
  99         # Lexwrap the subroutine
 100         Hook::LexWrap::wrap(
 101                 $subname,
 102                 pre => sub { $CALLS{$subname}++ },
 103         );
 104
 105         1;
 106 }
 107
 108 =pod
 109
 110 =head2 sub_calls $subname, $expected_calls [, $message ]
 111
 112 The C<sub_calls> function is the primary (and only) testing function
 113 provided by C<Test::SubCalls>. A single call will represent one test in
 114 your plan.
 115
 116 It takes the subroutine name as originally provided to C<sub_track>,
 117 the expected number of times the subroutine should have been called,
 118 and an optional test message.
 119
 120 If no message is provided, a default message will be provided for you.
 121
 122 Test is ok if the number of times the sub has been called matches the
 123 expected number, or not ok if not.
 124
 125 =cut
 126
 127 sub sub_calls {
 128         # Check the sub name is valid
 129         my $subname = shift;
 130         unless ( defined $CALLS{$subname} ) {
 131                 die "Test::SubCalls::sub_calls : Cannot test untracked sub '$subname'";
 132         }
 133
 134         # Check the count
 135         my $count = shift;
 136         unless ( $count =~ /^(?:0|[1-9]\d*)\z/s ) {
 137                 die "Test::SubCalls::sub_calls : Expected count '$count' is not an integer";
 138         }
 139
 140         # Get the message, applying default if needed
 141         my $message = shift || "$subname was called $count times";
 142         $Test->is_num( $CALLS{$subname}, $count, $message );
 143 }
 144
 145 =pod
 146
 147 =head2 sub_reset $subname
 148
 149 To prevent repeat users from having to take before and after counts when
 150 they start testing from after zero, the C<sub_reset> function has been
 151 provided to reset a sub call counter to zero.
 152
 153 Returns true or dies if the sub name is invalid or not currently tracked.
 154
 155 =cut
 156
 157 sub sub_reset {
 158         # Check the sub name is valid
 159         my $subname = shift;
 160         unless ( defined $CALLS{$subname} ) {
 161                 die "Test::SubCalls::sub_reset : Cannot reset untracked sub '$subname'";
 162         }
 163
 164         $CALLS{$subname} = 0;
 165
 166         1;
 167 }
 168
 169 =pod
 170
 171 =head2 sub_reset_all
 172
 173 Provided mainly as a convenience, the C<sub_reset_all> function will reset
 174 all the counters currently defined.
 175
 176 Returns true.
 177
 178 =cut
 179
 180 sub sub_reset_all {
 181         foreach my $subname ( keys %CALLS ) {
 182                 $CALLS{$subname} = 0;
 183         }
 184         1;
 185 }
 186
 187 1;
 188
 189 =pod
 190
 191 =head1 SUPPORT
 192
 193 Bugs should be submitted via the CPAN bug tracker, located at
 194
 195 L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Test-SubCalls>
 196
 197 For other issues, or commercial enhancement or support, contact the author.
 198
 199 =head1 AUTHOR
 200
 201 Adam Kennedy E<lt>adamk@cpan.orgE<gt>
 202
 203 =head1 SEE ALSO
 204
 205 L<http://ali.as/>, L<Test::Builder>, L<Test::More>, L<Hook::LexWrap>
 206
 207 =head1 COPYRIGHT
 208
 209 Copyright 2005 - 2009 Adam Kennedy.
 210
 211 This program is free software; you can redistribute
 212 it and/or modify it under the same terms as Perl itself.
 213
 214 The full text of the license can be found in the
 215 LICENSE file included with this module.
 216
 217 =cut