File Coverage

blib/lib/Test/Log/Log4perl.pm
Criterion Covered Total %
statement 146 174 83.9
branch 32 40 80.0
condition 14 18 77.7
subroutine 32 38 84.2
pod 4 11 36.3
total 228 281 81.1


line stmt bran cond sub pod time code
1             package Test::Log::Log4perl;
2 4     4   349470 use strict;
  4         10  
  4         139  
3 4     4   22 use warnings;
  4         7  
  4         123  
4              
5 4     4   49 use 5.8.8;
  4         18  
  4         169  
6              
7 4     4   22 use Test::Builder;
  4         13  
  4         160  
8             my $Tester = Test::Builder->new();
9              
10 4     4   25 use Carp qw(croak);
  4         8  
  4         218  
11 4     4   22 use Scalar::Util qw(blessed);
  4         6  
  4         414  
12 4     4   1402 use Log::Log4perl qw(:levels);
  4         54001  
  4         30  
13              
14             $Log::Log4perl::Logger::INITIALIZED = 1;
15             our $VERSION = '0.32';
16              
17             =head1 NAME
18              
19             Test::Log::Log4perl - test log4perl
20              
21             =head1 SYNOPSIS
22              
23             # setup l4p
24             use Log::Log4Perl;
25             # do your normal Log::Log4Perl setup here
26             use Test::Log::Log4perl;
27              
28             # get the loggers
29             my $logger = Log::Log4perl->get_logger("Foo::Bar");
30             my $tlogger = Test::Log::Log4perl->get_logger("Foo::Bar");
31              
32             # test l4p
33             Test::Log::Log4perl->start();
34              
35             # declare we're going to log something
36             $tlogger->error("This is a test");
37              
38             # log that something
39             $logger->error("This is a test");
40              
41             # test that those things matched
42             Test::Log::Log4perl->end("Test that that logs okay");
43              
44             # we also have a simplified version:
45             {
46             my $foo = Test::Log::Log4perl->expect(['foo.bar.quux', warn => qr/hello/ ]);
47             # ... do something that should log 'hello'
48             }
49             # $foo goes out of scope; this triggers the test.
50              
51             =head1 DESCRIPTION
52              
53             This module can be used to test that you're logging the right thing
54             with Log::Log4perl. It checks that we get what, and only what, we
55             expect logged by your code.
56              
57             The basic process is very simple. Within your test script you get
58             one or more loggers from B with the C method
59             just like you would with B. You're going to use these
60             loggers to declare what you think the code you're going to test should
61             be logging.
62              
63             # declare a bunch of test loggers
64             my $tlogger = Test::Log::Log4perl->get_logger("Foo::Bar");
65              
66             Then, for each test you want to do you need to start up the module.
67              
68             # start the test
69             Test::Log::Log4perl->start();
70              
71             This diverts all subsequent attempts B makes to log
72             stuff and records them internally rather than passing them though to
73             the Log4perl appenders as normal.
74              
75             You then need to declare with the loggers we created earlier what
76             we hope Log4perl will be asked to log. This is the same syntax as
77             Test::Log::Log4perl uses, except if you want you can use regular expressions:
78              
79             $tlogger->debug("fish");
80             $tlogger->warn(qr/bar/);
81              
82             You then need to run your code that you're testing.
83              
84             # call some code that hopefully will call the log4perl methods
85             # 'debug' with "fish" and 'warn' with something that contains 'bar'
86             some_code();
87              
88             We finally need to tell B that we're done and it
89             should do the comparisons.
90              
91             # start the test
92             Test::Log::Log4perl->end("test name");
93              
94             =head2 Methods
95              
96             =over
97              
98             =item get_logger($category)
99              
100             Returns a new instance of Test::Log::Log4perl that can be used to log
101             expected messages in the category passed.
102              
103             =cut
104              
105             sub get_logger
106             {
107 5     5 1 978 my $class = shift;
108 5         20 my $self = bless { category => shift }, $class;
109 5         14 return $self;
110             }
111              
112             =item Test::Log::Log4perl->expect(%start_args, ['dotted.path', 'warn' => qr(this), 'warn' => qr(that)], ..)
113              
114             Class convenience method. Used like this:
115              
116             { # start local scope
117             my $foo = Test::Log::Log4perl->expect(['foo.bar.quux', warn => qr/hello/ ]);
118             # ... do something that should log 'hello'
119             } # $foo goes out of scope; this triggers the test.
120              
121             =cut
122              
123             sub expect {
124 0     0 1 0 my $class = shift;
125 0         0 my (@start_args, @expects);
126 0         0 for (@_) {
127 0 0       0 if (ref($_) eq 'ARRAY') {
128 0         0 push @expects, $_;
129             }
130             else {
131 0         0 push @start_args, $_;
132             }
133             }
134 0         0 $class->start(@start_args);
135 0         0 my @loggers;
136 0         0 for (@expects) {
137 0         0 my $name = shift @$_;
138 0         0 my $tlogger = $class->get_logger($name);
139             # XXX: respect current loglevel
140 0         0 while (my ($level, $what) = splice(@$_, 0, 2)) {
141 0         0 $tlogger->$level($what);
142             }
143 0         0 push @loggers, $tlogger;
144             }
145 0         0 return \@loggers;
146             }
147              
148              
149             =item start
150              
151             Class method. Start logging. When you call this method it temporarily
152             redirects all logging from the standard logging locations to the
153             internal logging routine until end is called. Takes parameters to
154             change the behavior of this (and only this) test. See below.
155              
156             =cut
157              
158             # convet a string priority into a digit one
159             sub _to_d($)
160             {
161 8     8   11 my $priority = shift;
162              
163             # check the priority is all digits
164 8 50       46 if ($priority =~ /\D/)
165             {
166 8 100       29 if (lc($priority) eq "everything") { $priority = $OFF }
  3 100       7  
167 2         5 elsif (lc($priority) eq "nothing") { $priority = $ALL }
168 3         17 else { $priority = Log::Log4perl::Level::to_priority(uc $priority) }
169             }
170              
171 8         39 return $priority;
172             }
173              
174             # the list of things we've stored so far
175             our @expected;
176             our @logged;
177              
178             sub start
179             {
180 26     26 1 10179 my $class = shift;
181 26         47 my %args = @_;
182              
183             # empty the record
184 26         57 @logged = ();
185 26         39 @expected = ();
186 26         68 $class->interception_class->reset_temp;
187              
188             # the priority
189 26 50       87 if ($args{ignore_everything})
190 0         0 { $args{ignore_priority} = "everything" }
191 26 50       57 if ($args{ignore_nothing})
192 0         0 { $args{ignore_priority} = "nothing" }
193 26 100       64 if (exists $args{ignore_priority})
194 3         9 { $class->interception_class->set_temp("ignore_priority",_to_d $args{ignore_priority}) }
195              
196             # turn on the interception code
197 26         67 foreach (values %$Log::Log4perl::Logger::LOGGERS_BY_NAME)
198 52         110 { bless $_, $class->interception_class }
199             }
200              
201             =item debug(@what)
202              
203             =item info(@what)
204              
205             =item warn(@what)
206              
207             =item error(@what)
208              
209             =item fatal(@what)
210              
211             Instance methods. String of things that you're expecting to log, at
212             the level you're expecting them, in what class.
213              
214             =cut
215              
216             sub _log_at_level
217             {
218 30     30   38 my $self = shift;
219 30         34 my $priority = shift;
220 30 100       108 my $message = ref $_[0] ? shift : join '', grep defined, @_;
221              
222 30         160 push @expected, {
223             category => $self->{category},
224             priority => $priority,
225             message => $message,
226             };
227             }
228              
229             foreach my $level (qw(trace debug info warn error fatal))
230             {
231 4     4   2799 no strict 'refs';
  4         7  
  4         3998  
232             *{$level} = sub {
233 30     30   190 my $class = shift;
234 30         77 $class->_log_at_level($level, @_)
235             }
236             }
237              
238             =item end()
239              
240             =item end($name)
241              
242             Ends the test and compares what we've got with what we expected.
243             Switches logging back from being captured to going to wherever
244             it was originally directed in the config.
245              
246             =cut
247              
248             # eeek, the hard bit
249             sub end
250             {
251 24     24 1 1048 my $class = shift;
252 24   50     90 my $name = shift || "Log4perl test";
253              
254 24         53 $class->interception_class->set_temp("ended", 1);
255             # turn off the interception code
256 24         111 foreach (values %$Log::Log4perl::Logger::LOGGERS_BY_NAME)
257 48         159 { bless $_, $class->original_class }
258              
259 24         32 my $no;
260 24         61 while (@logged)
261             {
262 30         37 $no++;
263              
264 30         45 my $logged = shift @logged;
265 30         44 my $expected = shift @expected;
266              
267             # not expecting anything?
268 30 100       74 unless ($expected)
269             {
270 1         11 $Tester->ok(0,$name);
271 1         441 $Tester->diag("Unexpected $logged->{priority} of type '$logged->{category}':\n");
272 1         62 $Tester->diag(" '$logged->{message}'");
273 1         61 return 0;
274             }
275              
276             # was this message what we expected?
277             # ...
278 15         76 my %wrong = map { $_ => 1 }
  87         222  
279 29         362 grep { !_matches($logged->{ $_ }, $expected->{ $_ }) }
280             qw(category message priority);
281 29 100       190 if (%wrong)
282             {
283 9         35 $Tester->ok(0, $name);
284 9         4764 $Tester->diag("Message $no logged wasn't what we expected:");
285 9         640 foreach my $thingy (qw(category priority message))
286             {
287 27 100       621 if ($wrong{ $thingy })
288             {
289 15         132 $Tester->diag(sprintf(q{ %8s was '%s'}, $thingy, $logged->{ $thingy }));
290 15 100 66     1266 if (ref($expected->{ $thingy }) && ref($expected->{ $thingy }) eq "Regexp")
291 1         6 { $Tester->diag(" not like '$expected->{$thingy}'") }
292             else
293 14         58 { $Tester->diag(" not '$expected->{$thingy}'") }
294             }
295             }
296 9         1013 $Tester->diag(" (Offending log call from line $logged->{line} in $logged->{filename})");
297              
298 9         672 return 0
299              
300             }
301             }
302              
303             # expected something but didn't get it?
304 14 100       33 if (@expected)
305             {
306 1         5 $Tester->ok(0, $name);
307 1         418 $Tester->diag("Ended logging run, but still expecting ".@expected." more log(s)");
308 1         63 $Tester->diag("Expecting $expected[0]{priority} of type '$expected[0]{category}' next:");
309 1         61 $Tester->diag(" '$expected[0]{message}'");
310 1         58 return 0;
311             }
312              
313 13         55 $Tester->ok(1,$name);
314 13         4106 return 1;
315             }
316              
317             # this is essentially a trivial implementation of perl 6's smart match operator
318             sub _matches
319             {
320 95     95   660 my $got = shift;
321 95         110 my $expected = shift;
322              
323 95         121 my $ref = ref($expected);
324              
325             # compare as a string
326 95 100       198 unless ($ref)
327 87         282 { return $expected eq $got }
328              
329             # compare a regex?
330 8 100       21 if (ref($expected) eq "Regexp")
331 4         28 { return $got =~ $expected }
332              
333             # check if it's a reference to something, and die
334 4 100       25 if (!blessed($expected))
335 1         33 { croak "Don't know how to compare a reference to a $ref" }
336              
337             # it's an object. Is that overloaded in some way?
338             # (note we avoid calling overload::Overloaded unless someone has used
339             # the module first)
340 3 100 66     19 if (defined(&overload::Overloaded) && overload::Overloaded($expected))
341 2         92 { return $expected eq $got }
342            
343 1         3772 croak "Don't know how to compare object $ref";
344             }
345              
346             =back
347              
348             =head2 Ignoring All Logging Messages
349              
350             Sometimes you're going to be testing something that generates a load
351             of spurious log messages that you simply want to ignore without
352             testing their contents, but you don't want to have to reconfigure
353             your log file. The simplest way to do this is to do:
354              
355             use Test::Log::Log4perl;
356             Test::Log::Log4perl->suppress_logging;
357              
358             All logging functions stop working. Do not alter the Logging classes
359             (for example, by changing the config file and use Log4perl's
360             C functionality) after this call has been made.
361              
362             This function will be effectively a no-op if the environmental variable
363             C is set to a true value (so if your code is
364             behaving weirdly you can turn all the logging back on from the command
365             line without changing any of the code)
366              
367             =cut
368              
369             # TODO: What if someone calls ->start() after this then, eh?
370             # currently it'll test the logs and then stop suppressing logging
371             # is that what we want? Because that's what'll happen.
372              
373             sub suppress_logging
374             {
375 0     0 0 0 my $class = shift;
376              
377 0 0       0 return if $ENV{NO_SUPPRESS_LOGGING};
378              
379             # tell this to ignore everything.
380 0         0 foreach (values %$Log::Log4perl::Logger::LOGGERS_BY_NAME)
381 0         0 { bless $_, $class->ignore_all_class }
382             }
383              
384             =head2 Selectively Ignoring Logging Messages By Priority
385              
386             It's a bad idea to completely ignore all messages. What you probably
387             want to do is ignore some of the trivial messages that you don't
388             care about, and just test that there aren't any unexpected messages
389             of a set priority.
390              
391             You can temporarily ignore any logging messages that are made by
392             passing parameters to the C routine
393              
394             # for this test, just ignore DEBUG, INFO, and WARN
395             Test::Log::Log4perl->start( ignore_priority => "warn" );
396              
397             # you can use the levels constants to do the same thing
398             use Log::Log4perl qw(:levels);
399             Test::Log::Log4perl->start( ignore_priority => $WARN );
400              
401             You might want to ignore all logging events at all (this can be used
402             as quick way to not test the actual log messages, but just ignore the
403             output.
404              
405             # for this test, ignore everything
406             Test::Log::Log4perl->start( ignore_priority => "everything" );
407              
408             # contary to readability, the same thing (try not to write this)
409             use Log::Log4perl qw(:levels);
410             Test::Log::Log4perl->start( ignore_priority => $OFF );
411              
412             Or you might want to not ignore anything (which is the default, unless
413             you've played with the method calls mentioned below:)
414              
415             # for this test, ignore nothing
416             Test::Log::Log4perl->start( ignore_priority => "nothing" );
417              
418             # contary to readability, the same thing (try not to write this)
419             use Log::Log4perl qw(:levels);
420             Test::Log::Log4perl->start( ignore_priority => $ALL );
421              
422             You can also permanently effect what things are ignored with the
423             C method call. This persists between tests and isn't
424             automatically reset after each call to C.
425              
426             # ignore DEBUG, INFO and WARN for all future tests
427             Test::Log::Log4perl->ignore_priority("warn");
428              
429             # you can use the levels constants to do the same thing
430             use Log::Log4perl qw(:levels);
431             Test::Log::Log4perl->ignore_priority($WARN);
432              
433             # ignore everything (no log messages will be logged)
434             Test::Log::Log4perl->ignore_priority("everything");
435              
436             # ignore nothing (messages will be logged reguardless of priority)
437             Test::Log::Log4perl->ignore_priority("nothing");
438              
439             Obviously, you may temporarily override whatever permanent.
440              
441             =cut
442              
443             sub ignore_priority
444             {
445 5     5 0 23 my $class = shift;
446 5         11 my $p = _to_d shift;
447 5         13 $class->interception_class->set_temp("ignore_priority", $p);
448 5         11 $class->interception_class->set_perm("ignore_priority", $p);
449             }
450              
451             sub ignore_everything
452             {
453 0     0 0 0 my $class = shift;
454 0         0 $class->ignore_priority($OFF);
455             }
456              
457             sub ignore_nothing
458             {
459 0     0 0 0 my $class = shift;
460 0         0 $class->ignore_priority($ALL);
461             }
462              
463 120     120 0 423 sub interception_class { "Log::Log4perl::Logger::Interception" }
464 0     0 0 0 sub ignore_all_class { "Log::Log4perl::Logger::IgnoreAll" }
465 48     48 0 157 sub original_class { "Log::Log4perl::Logger" }
466              
467             sub DESTROY {
468 5 50   5   2078 return if $_[0]->interception_class->ended;
469 0         0 goto $_[0]->can('end');
470             }
471              
472             ###################################################################################################
473              
474             package Log::Log4perl::Logger::Interception;
475 4     4   28 use base qw(Log::Log4perl::Logger);
  4         8  
  4         458  
476 4     4   51 use Log::Log4perl qw(:levels);
  4         18  
  4         19  
477              
478             our %temp;
479             our %perm;
480              
481 26     26   54 sub reset_temp { %temp = () }
482 32     32   52 sub set_temp { my ($class, $key, $val) = @_; $temp{$key} = $val }
  32         80  
483 5     5   10 sub set_perm { my ($class, $key, $val) = @_; $perm{$key} = $val }
  5         16  
484 5     5   9 sub ended { my ($class) = @_; $temp{ended} }
  5         391  
485             # all the basic logging functions
486             foreach my $level (qw(trace debug info warn error fatal))
487             {
488 4     4   1029 no strict 'refs';
  4         7  
  4         1534  
489              
490             # we need to pass the number to log
491             my $level_int = Log::Log4perl::Level::to_priority(uc($level));
492 1     1   64 *{"is_".$level} = sub { 1 };
493             *{$level} = sub {
494 76     76   425 my $self = shift;
495 76         210 $self->log($level_int, @_)
496             }
497             }
498              
499             sub log
500             {
501 76     76   88 my $self = shift;
502 76         85 my $priority = shift;
503 76         192 my $message = join '', grep defined, @_;
504              
505             # are we logging anything or what?
506 76 100 100     568 if ($priority <= ($temp{ignore_priority} || 0) or
      100        
      100        
507             $priority <= ($perm{ignore_priority} || 0))
508 30         64 { return }
509              
510             # what's that priority called then?
511 46         146 my $priority_name = lc( Log::Log4perl::Level::to_level($priority) );
512              
513             # find the filename and line
514 46         353 my ($filename, $line);
515 46         83 my $cur_filename = _cur_filename();
516 46         63 my $level = 1;
517 46   66     53 do {
518 47         787 (undef, $filename, $line) = caller($level++);
519             } while ($filename eq $cur_filename || $filename eq $INC{"Log/Log4perl/Logger.pm"});
520              
521             # log it
522 46         322 push @Test::Log::Log4perl::logged, {
523             category => $self->{category}, # oops, there goes encapsulation
524             priority => $priority_name,
525             message => $message,
526             filename => $filename,
527             line => $line,
528             };
529              
530 46         134 return;
531             }
532              
533 46     46   137 sub _cur_filename { (caller)[1] }
534              
535             1;
536              
537             package Log::Log4perl::Logger::IgnoreAll;
538 4     4   23 use base qw(Log::Log4perl::Logger);
  4         5  
  4         346  
539              
540             # all the functions we don't want
541             foreach my $level (qw(trace debug info warn error fatal log))
542             {
543 4     4   20 no strict 'refs';
  4         19  
  4         342  
544 0     0     *{$level} = sub { return () }
545             }
546              
547             =head1 BUGS
548              
549             Logging methods don't return the number of appenders they've written
550             to (or rather, they do, as it's always zero.)
551              
552             Changing the config file (if you're watching it) while this is testing
553             / suppressing everything will probably break everything. As will
554             creating new appenders, etc...
555              
556             =head1 AUTHOR
557              
558             Chia-liang Kao
559             Mark Fowler
560              
561             =head1 COPYRIGHT
562              
563             Copyright 2010 Chia-liang Kao all rights reserved.
564             Copyright 2005 Fotango Ltd all rights reserved.
565              
566             Licensed under the same terms as Perl itself.
567              
568             =cut
569              
570             1;