File Coverage

blib/lib/Log/Log4perl/Filter/Boolean.pm
Criterion Covered Total %
statement 51 52 98.0
branch 4 6 66.6
condition n/a
subroutine 12 12 100.0
pod 0 4 0.0
total 67 74 90.5


line stmt bran cond sub pod time code
1             ##################################################
2             ##################################################
3              
4             use 5.006;
5 70     70   1160  
  70         212  
6             use strict;
7 70     70   296 use warnings;
  70         114  
  70         1215  
8 70     70   298  
  70         123  
  70         1606  
9             use Log::Log4perl::Level;
10 70     70   326 use Log::Log4perl::Config;
  70         117  
  70         395  
11 70     70   363  
  70         144  
  70         1823  
12             use constant _INTERNAL_DEBUG => 0;
13 70     70   342  
  70         152  
  70         3519  
14             use base qw(Log::Log4perl::Filter);
15 70     70   371  
  70         121  
  70         39751  
16             ##################################################
17             ##################################################
18             my ($class, %options) = @_;
19              
20 3     3 0 8 my $self = { params => {},
21             %options,
22 3         11 };
23            
24             bless $self, $class;
25            
26 3         5 print "Compiling '$options{logic}'\n" if _INTERNAL_DEBUG;
27              
28 3         3 # Set up meta-decider for later
29             $self->compile_logic($options{logic});
30              
31 3         9 return $self;
32             }
33 3         9  
34             ##################################################
35             ##################################################
36             my ($self, %p) = @_;
37              
38             return $self->eval_logic(\%p);
39 7     7 0 21 }
40              
41 7         17 ##################################################
42             ##################################################
43             my ($self, $logic) = @_;
44              
45             # Extract Filter placeholders in logic as defined
46             # in configuration file.
47 3     3 0 5 while($logic =~ /([\w_-]+)/g) {
48             # Get the corresponding filter object
49             my $filter = Log::Log4perl::Filter::by_name($1);
50             die "Filter $1 required by Boolean filter, but not defined"
51 3         16 unless $filter;
52              
53 7         13 $self->{params}->{$1} = $filter;
54 7 50       12 }
55              
56             # Fabricate a parameter list: A1/A2/A3 => $A1, $A2, $A3
57 7         25 my $plist = join ', ', map { '$' . $_ } keys %{$self->{params}};
58              
59             # Replace all the (dollar-less) placeholders in the code with
60             # calls to their respective coderefs.
61 3         4 $logic =~ s/([\w_-]+)/\&\$$1/g;
  7         15  
  3         9  
62              
63             # Set up the meta decider, which transforms the config file
64             # logic into compiled perl code
65 3         19 my $func = <<EOT;
66             sub {
67             my($plist) = \@_;
68             $logic;
69 3         9 }
70             EOT
71              
72             print "func=$func\n" if _INTERNAL_DEBUG;
73              
74             my $eval_func = eval $func;
75              
76 3         4 if(! $eval_func) {
77             die "Syntax error in Boolean filter logic: $eval_func";
78 3         196 }
79              
80 3 50       9 $self->{eval_func} = $eval_func;
81 0         0 }
82              
83             ##################################################
84 3         7 ##################################################
85             my($self, $p) = @_;
86              
87             my @plist = ();
88              
89             # Eval the results of all filters referenced
90 7     7 0 11 # in the code (although the order of keys is
91             # not predictable, it is consistent :)
92 7         11 for my $param (keys %{$self->{params}}) {
93             # Pass a coderef as a param that will run the filter's ok method and
94             # return a 1 or 0.
95             print "Passing filter $param\n" if _INTERNAL_DEBUG;
96             push(@plist, sub {
97 7         8 return $self->{params}->{$param}->ok(%$p) ? 1 : 0
  7         16  
98             });
99             }
100 19         21  
101             # Now pipe the parameters into the canned function,
102 10 100   10   32 # have it evaluate the logic and return the final
103 19         39 # decision
104             print "Passing in (", join(', ', @plist), ")\n" if _INTERNAL_DEBUG;
105             return $self->{eval_func}->(@plist);
106             }
107              
108             1;
109 7         10  
110 7         138  
111             =encoding utf8
112              
113             =head1 NAME
114              
115             Log::Log4perl::Filter::Boolean - Special filter to combine the results of others
116              
117             =head1 SYNOPSIS
118              
119             log4perl.logger = WARN, AppWarn, AppError
120              
121             log4perl.filter.Match1 = sub { /let this through/ }
122             log4perl.filter.Match2 = sub { /and that, too/ }
123             log4perl.filter.MyBoolean = Log::Log4perl::Filter::Boolean
124             log4perl.filter.MyBoolean.logic = Match1 || Match2
125              
126             log4perl.appender.Screen = Log::Dispatch::Screen
127             log4perl.appender.Screen.Filter = MyBoolean
128             log4perl.appender.Screen.layout = Log::Log4perl::Layout::SimpleLayout
129              
130             =head1 DESCRIPTION
131              
132             Sometimes, it's useful to combine the output of various filters to
133             arrive at a log/no log decision. While Log4j, Log4perl's mother ship,
134             chose to implement this feature as a filter chain, similar to Linux' IP chains,
135             Log4perl tries a different approach.
136              
137             Typically, filter results will not need to be passed along in chains but
138             combined in a programmatic manner using boolean logic. "Log if
139             this filter says 'yes' and that filter says 'no'"
140             is a fairly common requirement but hard to implement as a chain.
141              
142             C<Log::Log4perl::Filter::Boolean> is a special predefined custom filter
143             for Log4perl which combines the results of other custom filters
144             in arbitrary ways, using boolean expressions:
145              
146             log4perl.logger = WARN, AppWarn, AppError
147              
148             log4perl.filter.Match1 = sub { /let this through/ }
149             log4perl.filter.Match2 = sub { /and that, too/ }
150             log4perl.filter.MyBoolean = Log::Log4perl::Filter::Boolean
151             log4perl.filter.MyBoolean.logic = Match1 || Match2
152              
153             log4perl.appender.Screen = Log::Dispatch::Screen
154             log4perl.appender.Screen.Filter = MyBoolean
155             log4perl.appender.Screen.layout = Log::Log4perl::Layout::SimpleLayout
156              
157             C<Log::Log4perl::Filter::Boolean>'s boolean expressions allow for combining
158             different appenders by name using AND (&& or &), OR (|| or |) and NOT (!) as
159             logical expressions. Parentheses are used for grouping. Precedence follows
160             standard Perl. Here's a bunch of examples:
161              
162             Match1 && !Match2 # Match1 and not Match2
163             !(Match1 || Match2) # Neither Match1 nor Match2
164             (Match1 && Match2) || Match3 # Both Match1 and Match2 or Match3
165              
166             =head1 SEE ALSO
167              
168             L<Log::Log4perl::Filter>,
169             L<Log::Log4perl::Filter::LevelMatch>,
170             L<Log::Log4perl::Filter::LevelRange>,
171             L<Log::Log4perl::Filter::MDC>,
172             L<Log::Log4perl::Filter::StringRange>
173              
174             =head1 LICENSE
175              
176             Copyright 2002-2013 by Mike Schilli E<lt>m@perlmeister.comE<gt>
177             and Kevin Goess E<lt>cpan@goess.orgE<gt>.
178              
179             This library is free software; you can redistribute it and/or modify
180             it under the same terms as Perl itself.
181              
182             =head1 AUTHOR
183              
184             Please contribute patches to the project on Github:
185              
186             http://github.com/mschilli/log4perl
187              
188             Send bug reports or requests for enhancements to the authors via our
189              
190             MAILING LIST (questions, bug reports, suggestions/patches):
191             log4perl-devel@lists.sourceforge.net
192              
193             Authors (please contact them via the list above, not directly):
194             Mike Schilli <m@perlmeister.com>,
195             Kevin Goess <cpan@goess.org>
196              
197             Contributors (in alphabetical order):
198             Ateeq Altaf, Cory Bennett, Jens Berthold, Jeremy Bopp, Hutton
199             Davidson, Chris R. Donnelly, Matisse Enzer, Hugh Esco, Anthony
200             Foiani, James FitzGibbon, Carl Franks, Dennis Gregorovic, Andy
201             Grundman, Paul Harrington, Alexander Hartmaier David Hull,
202             Robert Jacobson, Jason Kohles, Jeff Macdonald, Markus Peter,
203             Brett Rann, Peter Rabbitson, Erik Selberg, Aaron Straup Cope,
204             Lars Thegler, David Viner, Mac Yang.
205