File Coverage

blib/lib/Log/Log4perl/Filter/StringMatch.pm
Criterion Covered Total %
statement 36 36 100.0
branch 2 2 100.0
condition n/a
subroutine 9 9 100.0
pod 0 2 0.0
total 47 49 95.9


line stmt bran cond sub pod time code
1             ##################################################
2             ##################################################
3              
4             use 5.006;
5 1     1   30  
  1         3  
6             use strict;
7 1     1   5 use warnings;
  1         3  
  1         61  
8 1     1   6  
  1         2  
  1         44  
9             use Log::Log4perl::Config;
10 1     1   8 use Log::Log4perl::Util qw( params_check );
  1         3  
  1         38  
11 1     1   7  
  1         1  
  1         64  
12             use constant _INTERNAL_DEBUG => 0;
13 1     1   5  
  1         12  
  1         89  
14             use base "Log::Log4perl::Filter";
15 1     1   7  
  1         2  
  1         420  
16             ##################################################
17             ##################################################
18             my ($class, %options) = @_;
19              
20 3     3 0 19 print join('-', %options) if _INTERNAL_DEBUG;
21              
22 3         5 my $self = { StringToMatch => undef,
23             AcceptOnMatch => 1,
24 3         21 %options,
25             };
26            
27             params_check( $self,
28             [ qw( StringToMatch ) ],
29 3         22 [ qw( name AcceptOnMatch ) ]
30             );
31              
32             $self->{AcceptOnMatch} = Log::Log4perl::Config::boolean_to_perlish(
33             $self->{AcceptOnMatch});
34              
35 3         14 $self->{StringToMatch} = qr($self->{StringToMatch});
36              
37 3         48 bless $self, $class;
38              
39 3         10 return $self;
40             }
41 3         9  
42             ##################################################
43             ##################################################
44             my ($self, %p) = @_;
45              
46             local($_) = join $
47 9     9 0 35 Log::Log4perl::JOIN_MSG_ARRAY_CHAR, @{$p{message}};
48              
49             if($_ =~ $self->{StringToMatch}) {
50 9         16 print "Strings match\n" if _INTERNAL_DEBUG;
  9         27  
51             return $self->{AcceptOnMatch};
52 9 100       48 } else {
53 5         7 print "Strings don't match ($_/$self->{StringToMatch})\n"
54 5         97 if _INTERNAL_DEBUG;
55             return !$self->{AcceptOnMatch};
56 4         7 }
57             }
58 4         59  
59             1;
60              
61              
62             =encoding utf8
63              
64             =head1 NAME
65              
66             Log::Log4perl::Filter::StringMatch - Filter on log message string
67              
68             =head1 SYNOPSIS
69              
70             log4perl.filter.Match1 = Log::Log4perl::Filter::StringMatch
71             log4perl.filter.Match1.StringToMatch = blah blah
72             log4perl.filter.Match1.AcceptOnMatch = true
73              
74             =head1 DESCRIPTION
75              
76             This Log4perl custom filter checks if the currently submitted message
77             matches a predefined regular expression, as set in the C<StringToMatch>
78             parameter. It uses common Perl 5 regexes.
79              
80             The additional parameter C<AcceptOnMatch> defines if the filter
81             is supposed to pass or block the message on a match (C<true> or C<false>).
82              
83             =head1 SEE ALSO
84              
85             L<Log::Log4perl::Filter>,
86             L<Log::Log4perl::Filter::Boolean>,
87             L<Log::Log4perl::Filter::LevelMatch>,
88             L<Log::Log4perl::Filter::LevelRange>,
89             L<Log::Log4perl::Filter::MDC>
90              
91             =head1 LICENSE
92              
93             Copyright 2002-2013 by Mike Schilli E<lt>m@perlmeister.comE<gt>
94             and Kevin Goess E<lt>cpan@goess.orgE<gt>.
95              
96             This library is free software; you can redistribute it and/or modify
97             it under the same terms as Perl itself.
98              
99             =head1 AUTHOR
100              
101             Please contribute patches to the project on Github:
102              
103             http://github.com/mschilli/log4perl
104              
105             Send bug reports or requests for enhancements to the authors via our
106              
107             MAILING LIST (questions, bug reports, suggestions/patches):
108             log4perl-devel@lists.sourceforge.net
109              
110             Authors (please contact them via the list above, not directly):
111             Mike Schilli <m@perlmeister.com>,
112             Kevin Goess <cpan@goess.org>
113              
114             Contributors (in alphabetical order):
115             Ateeq Altaf, Cory Bennett, Jens Berthold, Jeremy Bopp, Hutton
116             Davidson, Chris R. Donnelly, Matisse Enzer, Hugh Esco, Anthony
117             Foiani, James FitzGibbon, Carl Franks, Dennis Gregorovic, Andy
118             Grundman, Paul Harrington, Alexander Hartmaier David Hull,
119             Robert Jacobson, Jason Kohles, Jeff Macdonald, Markus Peter,
120             Brett Rann, Peter Rabbitson, Erik Selberg, Aaron Straup Cope,
121             Lars Thegler, David Viner, Mac Yang.
122