t/lib/Mocks/Logger.pm

   1 package t::lib::Mocks::Logger;
   2
   3 # This file is part of Koha.
   4 #
   5 # Koha is free software; you can redistribute it and/or modify it
   6 # under the terms of the GNU General Public License as published by
   7 # the Free Software Foundation; either version 3 of the License, or
   8 # (at your option) any later version.
   9 #
  10 # Koha is distributed in the hope that it will be useful, but
  11 # WITHOUT ANY WARRANTY; without even the implied warranty of
  12 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
  13 # GNU General Public License for more details.
  14 #
  15 # You should have received a copy of the GNU General Public License
  16 # along with Koha; if not, see <http://www.gnu.org/licenses>.
  17
  18 use Modern::Perl;
  19
  20 use base 'Test::Builder::Module';
  21 use base qw(Class::Accessor);
  22
  23 use Test::MockModule;
  24 use Test::MockObject;
  25
  26 my $CLASS = __PACKAGE__;
  27
  28 =head1 NAME
  29
  30 t::lib::Mocks::Logger - A library to mock Koha::Logger for testing
  31
  32 =head1 API
  33
  34 =head2 Methods
  35
  36 =head3 new
  37
  38     my $logger = t::lib::Mocks::Logger->new();
  39
  40 Mocks the Koha::Logger for testing purposes. The mocked subs (log levels)
  41 return the passed string, in case we want to test the debugging string contents.
  42
  43 =cut
  44
  45 sub new {
  46     my ( $class, $params ) = @_;
  47
  48     my $mocked_logger_class = Test::MockModule->new("Koha::Logger");
  49     my $mocked_logger = Test::MockObject->new();
  50
  51     $mocked_logger_class->mock(
  52         'get',
  53         sub {
  54             return $mocked_logger;
  55         }
  56     );
  57
  58     my $self = $class->SUPER::new(
  59         {   logger => $mocked_logger_class,
  60             debug  => [],
  61             error  => [],
  62             info   => [],
  63             fatal  => [],
  64             trace  => [],
  65             warn   => [],
  66         }
  67     );
  68     bless $self, $class;
  69
  70     foreach my $level (levels()) {
  71         $mocked_logger->mock(
  72             $level,
  73             sub {
  74                 my $message = $_[1];
  75                 push @{ $self->{$level} }, $message;
  76                 return $message;
  77             }
  78         );
  79     }
  80
  81     return $self;
  82 }
  83
  84 =head3 debug_is
  85
  86     $logger->debug_is($expected);
  87
  88 Method for testing a message was written to the 'debug' log level.
  89
  90 =cut
  91
  92 sub debug_is {
  93     my ( $self, $expect, $name ) = @_; $self->generic_is( 'debug', $expect, $name ); return $self;
  94 }
  95
  96 =head3 error_is
  97
  98     $logger->error_is($expected);
  99
 100 Method for testing a message was written to the 'error' log level.
 101
 102 =cut
 103
 104 sub error_is {
 105     my ( $self, $expect, $name ) = @_; $self->generic_is( 'error', $expect, $name ); return $self;
 106 }
 107
 108 =head3 fatal_is
 109
 110     $logger->fatal_is($expected);
 111
 112 Method for testing a message was written to the 'fatal' log level.
 113
 114 =cut
 115
 116 sub fatal_is {
 117     my ( $self, $expect, $name ) = @_; $self->generic_is( 'fatal', $expect, $name ); return $self;
 118 }
 119
 120 =head3 info_is
 121
 122     $logger->info_is($expected);
 123
 124 Method for testing a message was written to the 'info' log level.
 125
 126 =cut
 127
 128 sub info_is {
 129     my ( $self, $expect, $name ) = @_; $self->generic_is( 'info', $expect, $name ); return $self;
 130 }
 131
 132 =head3 trace_is
 133
 134     $logger->trace_is($expected);
 135
 136 Method for testing a message was written to the 'trace' log level.
 137
 138 =cut
 139
 140 sub trace_is {
 141     my ( $self, $expect, $name ) = @_; $self->generic_is( 'trace', $expect, $name ); return $self;
 142 }
 143
 144 =head3 warn_is
 145
 146     $logger->warn_is($expected);
 147
 148 Method for testing a message was written to the 'warn' log level.
 149
 150 =cut
 151
 152 sub warn_is {
 153     my ( $self, $expect, $name ) = @_; $self->generic_is( 'warn', $expect, $name ); return $self;
 154 }
 155
 156 =head3 debug_like
 157
 158     $logger->debug_like($expected);
 159
 160 Method for testing a message matching a regex was written to the 'debug' log level.
 161
 162 =cut
 163
 164 sub debug_like {
 165     my ( $self, $expect, $name ) = @_; $self->generic_like( 'debug', $expect, $name ); return $self;
 166 }
 167
 168 =head3 error_like
 169
 170     $logger->error_like($expected);
 171
 172 Method for testing a message matching a regex was written to the 'error' log level.
 173
 174 =cut
 175
 176 sub error_like {
 177     my ( $self, $expect, $name ) = @_; $self->generic_like( 'error', $expect, $name ); return $self;
 178 }
 179
 180 =head3 fatal_like
 181
 182     $logger->fatal_like($expected);
 183
 184 Method for testing a message matching a regex was written to the 'fatal' log level.
 185
 186 =cut
 187
 188 sub fatal_like {
 189     my ( $self, $expect, $name ) = @_; $self->generic_like( 'fatal', $expect, $name ); return $self;
 190 }
 191
 192 =head3 info_like
 193
 194     $logger->info_like($expected);
 195
 196 Method for testing a message matching a regex was written to the 'info' log level.
 197
 198 =cut
 199
 200 sub info_like {
 201     my ( $self, $expect, $name ) = @_; $self->generic_like( 'info', $expect, $name ); return $self;
 202 }
 203
 204 =head3 trace_like
 205
 206     $logger->trace_like($expected);
 207
 208 Method for testing a message matching a regex was written to the 'trace' log level.
 209
 210 =cut
 211
 212 sub trace_like {
 213     my ( $self, $expect, $name ) = @_; $self->generic_like( 'trace', $expect, $name ); return $self;
 214 }
 215
 216 =head3 warn_like
 217
 218     $logger->warn_like($expected);
 219
 220 Method for testing a message matching a regex was written to the 'warn' log level.
 221
 222 =cut
 223
 224 sub warn_like {
 225     my ( $self, $expect, $name ) = @_; $self->generic_like( 'warn', $expect, $name ); return $self;
 226 }
 227
 228 =head3 count
 229
 230     is( $logger->count( [ $level ] ), 0 'No logs!' );
 231
 232 Method for counting the generated messages. An optional I<$level> parameter
 233 can be passed to restrict the count to the passed level.
 234
 235 =cut
 236
 237 sub count {
 238     my ( $self, $level ) = @_;
 239
 240     unless ( $level ) {
 241         my $sum = 0;
 242
 243         map { $sum += scalar @{$self->{$_}} } levels();
 244
 245         return $sum;
 246     }
 247
 248     return scalar @{ $self->{$level} };
 249 }
 250
 251 =head3 clear
 252
 253     $logger->debug_is( "Something", "Something was sent to 'debug'" )
 254            ->warn_like( qr/^Something$/, "Something was sent to 'warn" )
 255            ->clear( [ $level ] );
 256
 257 A method for resetting the mocked I<$logger> object buffer. Useful to avoid inter-tests
 258 pollution.
 259
 260 =cut
 261
 262 sub clear {
 263     my ( $self, $level ) = @_;
 264
 265     if ( $level ) {
 266         $self->{$level} = [];
 267     }
 268     else {
 269         foreach my $l (levels()) {
 270             $self->{$l} = [];
 271         }
 272     }
 273
 274     return $self;
 275 }
 276
 277 =head2 Internal methods
 278
 279 =head3 generic_is
 280
 281 Internal method to be used to build log level-specific exact string test methods.
 282
 283 =cut
 284
 285 sub generic_is {
 286     my ( $self, $level, $expect, $name ) = @_;
 287
 288     local $Test::Builder::Level = $Test::Builder::Level + 1;
 289
 290     my $string = shift @{ $self->{$level} };
 291     $string //= '';
 292     my $tb = $CLASS->builder;
 293     return $tb->is_eq( $string, $expect, $name);
 294 }
 295
 296 =head3 generic_like
 297
 298 Internal method to be used to build log level-specific regex string test methods.
 299
 300 =cut
 301
 302 sub generic_like {
 303     my ( $self, $level, $expect, $name ) = @_;
 304
 305     local $Test::Builder::Level = $Test::Builder::Level + 1;
 306
 307     my $string = shift @{ $self->{$level} };
 308     $string //= '';
 309     my $tb = $CLASS->builder;
 310     return $tb->like( $string, $expect, $name);
 311 }
 312
 313 =head3 levels
 314
 315 Internal method that returns a list of valid log levels.
 316
 317 =cut
 318
 319 sub levels {
 320     return qw(trace debug info warn error fatal);
 321 }
 322
 323 1;