Filename | /usr/local/lib/site_perl/Log/Filter/Re.pm |
Statements | Executed 28 statements in 970µs |
Calls | P | F | Exclusive Time |
Inclusive Time |
Subroutine |
---|---|---|---|---|---|
1 | 1 | 1 | 25µs | 28µs | BEGIN@2 | Log::Filter::Re::
1 | 1 | 1 | 9µs | 34µs | BEGIN@108 | Log::Filter::Re::
1 | 1 | 1 | 8µs | 8µs | BEGIN@89 | Log::Filter::Re::
1 | 1 | 1 | 8µs | 33µs | BEGIN@110 | Log::Filter::Re::
1 | 1 | 1 | 7µs | 12µs | BEGIN@3 | Log::Filter::Re::
1 | 1 | 1 | 7µs | 31µs | BEGIN@114 | Log::Filter::Re::
1 | 1 | 1 | 7µs | 41µs | BEGIN@81 | Log::Filter::Re::
1 | 1 | 1 | 7µs | 38µs | BEGIN@107 | Log::Filter::Re::
1 | 1 | 1 | 7µs | 31µs | BEGIN@111 | Log::Filter::Re::
1 | 1 | 1 | 7µs | 40µs | BEGIN@90 | Log::Filter::Re::
1 | 1 | 1 | 6µs | 30µs | BEGIN@113 | Log::Filter::Re::
1 | 1 | 1 | 5µs | 5µs | BEGIN@86 | Log::Filter::Re::
1 | 1 | 1 | 2µs | 2µs | END | Log::Filter::Re::
0 | 0 | 0 | 0s | 0s | _field_int | Log::Filter::Re::
0 | 0 | 0 | 0s | 0s | _init | Log::Filter::Re::
0 | 0 | 0 | 0s | 0s | accept | Log::Filter::Re::
Line | State ments |
Time on line |
Calls | Time in subs |
Code |
---|---|---|---|---|---|
1 | package Log::Filter::Re; | ||||
2 | 2 | 23µs | 2 | 31µs | # spent 28µs (25+3) within Log::Filter::Re::BEGIN@2 which was called:
# once (25µs+3µs) by Log::Loger::BEGIN@124 at line 2 # spent 28µs making 1 call to Log::Filter::Re::BEGIN@2
# spent 3µs making 1 call to strict::import |
3 | 2 | 62µs | 2 | 17µs | # spent 12µs (7+5) within Log::Filter::Re::BEGIN@3 which was called:
# once (7µs+5µs) by Log::Loger::BEGIN@124 at line 3 # spent 12µs making 1 call to Log::Filter::Re::BEGIN@3
# spent 5µs making 1 call to warnings::import |
4 | |||||
5 | ################################################################################ | ||||
6 | # | ||||
7 | # DOCUMENTATION SECTION | ||||
8 | # | ||||
9 | ################################################################################ | ||||
10 | |||||
11 | =head1 NAME | ||||
12 | |||||
13 | Log::Filter::Re - Test given message field for values according the given PCRE patterns | ||||
14 | |||||
15 | =head1 SYNOPSIS | ||||
16 | |||||
17 | use Log::Filter::Re; | ||||
18 | |||||
19 | my $filter = new Log::Filter::Re('source','modul.*[a|b]'); | ||||
20 | my $filter = new Log::Filter::Re('severity','error'); | ||||
21 | my $filter = new Log::Filter::Re('message',['127.0.0.1','^notice'],'i r'); | ||||
22 | |||||
23 | my ($result, $continue) = $filter->accept($source, $severity, $message); | ||||
24 | |||||
25 | =head1 DESCRIPTION | ||||
26 | |||||
27 | This module accepts messages, whose given field comply to the at least one of the given | ||||
28 | PCRE patterns. | ||||
29 | |||||
30 | There are two flags, that are altering the avaluation process: | ||||
31 | |||||
32 | i - Invert the result of the evaluation - | ||||
33 | ACCEPT => REJECT | ||||
34 | REJECT => ACCEPT | ||||
35 | r - By default, module`s evaluation is SUFFICIENT - | ||||
36 | ACCEPT => FINISH | ||||
37 | REJECT => CONTINUE | ||||
38 | By setting the flag 'r', module`s evaluation will be REQUIRED - | ||||
39 | ACCEPT => CONTINUE | ||||
40 | REJECT => FINISH | ||||
41 | |||||
42 | =head1 USAGE | ||||
43 | |||||
44 | =head1 BUGS | ||||
45 | |||||
46 | =head1 SUPPORT | ||||
47 | |||||
48 | =head1 AUTHOR | ||||
49 | |||||
50 | Jan Mach | ||||
51 | Cesnet, z.s.p.o | ||||
52 | jan.mach@cesnet.cz | ||||
53 | http://www.cesnet.cz | ||||
54 | |||||
55 | =head1 COPYRIGHT | ||||
56 | |||||
57 | This program is free software; you can redistribute | ||||
58 | it and/or modify it under the same terms as Perl itself. | ||||
59 | |||||
60 | The full text of the license can be found in the | ||||
61 | LICENSE file included with this module. | ||||
62 | |||||
63 | |||||
64 | =head1 SEE ALSO | ||||
65 | |||||
66 | perl(1). | ||||
67 | |||||
68 | =head1 FUNCTION REFERENCE | ||||
69 | |||||
70 | =over 4 | ||||
71 | |||||
72 | =cut | ||||
73 | |||||
74 | ################################################################################ | ||||
75 | # | ||||
76 | # INITIALIZATION AND CLEANUP SECTION | ||||
77 | # | ||||
78 | ################################################################################ | ||||
79 | |||||
80 | #-- Perl core modules ---------------------------------------------------------# | ||||
81 | 2 | 24µs | 2 | 75µs | # spent 41µs (7+34) within Log::Filter::Re::BEGIN@81 which was called:
# once (7µs+34µs) by Log::Loger::BEGIN@124 at line 81 # spent 41µs making 1 call to Log::Filter::Re::BEGIN@81
# spent 34µs making 1 call to Exporter::import |
82 | |||||
83 | #-- Perl CPAN modules ---------------------------------------------------------# | ||||
84 | |||||
85 | #-- Custom application modules ------------------------------------------------# | ||||
86 | 2 | 30µs | 1 | 5µs | # spent 5µs within Log::Filter::Re::BEGIN@86 which was called:
# once (5µs+0s) by Log::Loger::BEGIN@124 at line 86 # spent 5µs making 1 call to Log::Filter::Re::BEGIN@86 |
87 | |||||
88 | #-- Module initializations ----------------------------------------------------# | ||||
89 | # spent 8µs within Log::Filter::Re::BEGIN@89 which was called:
# once (8µs+0s) by Log::Loger::BEGIN@124 at line 93 | ||||
90 | 2 | 30µs | 2 | 74µs | # spent 40µs (7+34) within Log::Filter::Re::BEGIN@90 which was called:
# once (7µs+34µs) by Log::Loger::BEGIN@124 at line 90 # spent 40µs making 1 call to Log::Filter::Re::BEGIN@90
# spent 34µs making 1 call to vars::import |
91 | 1 | 400ns | $VERSION = '0.01'; | ||
92 | 1 | 7µs | @ISA = ('Log::Filter::Module'); | ||
93 | 1 | 36µs | 1 | 8µs | } # spent 8µs making 1 call to Log::Filter::Re::BEGIN@89 |
94 | |||||
95 | #-- Module clean-up code (global destructor) ----------------------------------# | ||||
96 | 1 | 2µs | # spent 2µs within Log::Filter::Re::END which was called:
# once (2µs+0s) by main::RUNTIME at line 0 of mentat.storage.mongo.pl | ||
97 | |||||
98 | } | ||||
99 | |||||
100 | ################################################################################ | ||||
101 | # | ||||
102 | # CONSTANTS AND GLOBAL VARIABLES DEFINITION SECTION | ||||
103 | # | ||||
104 | ################################################################################ | ||||
105 | |||||
106 | #-- Constants -----------------------------------------------------------------# | ||||
107 | 2 | 27µs | 2 | 68µs | # spent 38µs (7+31) within Log::Filter::Re::BEGIN@107 which was called:
# once (7µs+31µs) by Log::Loger::BEGIN@124 at line 107 # spent 38µs making 1 call to Log::Filter::Re::BEGIN@107
# spent 31µs making 1 call to constant::import |
108 | 2 | 31µs | 2 | 59µs | # spent 34µs (9+25) within Log::Filter::Re::BEGIN@108 which was called:
# once (9µs+25µs) by Log::Loger::BEGIN@124 at line 108 # spent 34µs making 1 call to Log::Filter::Re::BEGIN@108
# spent 25µs making 1 call to constant::import |
109 | |||||
110 | 2 | 28µs | 2 | 59µs | # spent 33µs (8+26) within Log::Filter::Re::BEGIN@110 which was called:
# once (8µs+26µs) by Log::Loger::BEGIN@124 at line 110 # spent 33µs making 1 call to Log::Filter::Re::BEGIN@110
# spent 26µs making 1 call to constant::import |
111 | 2 | 25µs | 2 | 55µs | # spent 31µs (7+24) within Log::Filter::Re::BEGIN@111 which was called:
# once (7µs+24µs) by Log::Loger::BEGIN@124 at line 111 # spent 31µs making 1 call to Log::Filter::Re::BEGIN@111
# spent 24µs making 1 call to constant::import |
112 | |||||
113 | 2 | 25µs | 2 | 54µs | # spent 30µs (6+24) within Log::Filter::Re::BEGIN@113 which was called:
# once (6µs+24µs) by Log::Loger::BEGIN@124 at line 113 # spent 30µs making 1 call to Log::Filter::Re::BEGIN@113
# spent 24µs making 1 call to constant::import |
114 | 2 | 612µs | 2 | 54µs | # spent 31µs (7+24) within Log::Filter::Re::BEGIN@114 which was called:
# once (7µs+24µs) by Log::Loger::BEGIN@124 at line 114 # spent 31µs making 1 call to Log::Filter::Re::BEGIN@114
# spent 24µs making 1 call to constant::import |
115 | |||||
116 | #-- Static public class variables (our) ---------------------------------------# | ||||
117 | |||||
118 | #-- Static protected class variables (my) -------------------------------------# | ||||
119 | |||||
120 | # Translation table from message fields to indexes | ||||
121 | 1 | 2µs | my %FIELD2INDEX = ( 'SOURCE' => 0, | ||
122 | 'SEVERITY' => 1, | ||||
123 | 'MESSAGE' => 2, | ||||
124 | ); | ||||
125 | # Translation table from indexes to message fields | ||||
126 | 1 | 1µs | my @INDEX2FIELD = ( 'SOURCE', | ||
127 | 'SEVERITY', | ||||
128 | 'MESSAGE', | ||||
129 | ); | ||||
130 | |||||
131 | ################################################################################ | ||||
132 | # | ||||
133 | # IMPLEMENTATION SECTION | ||||
134 | # | ||||
135 | ################################################################################ | ||||
136 | |||||
137 | =item accept($$$) [PUBLIC] | ||||
138 | |||||
139 | Usage : my ($result, $continue) = $filter->accept($source, $severity, $message); | ||||
140 | Purpose : Check, if the filter will accept the given message | ||||
141 | Returns : Array (Log::Filter::Module::ACCEPT|REJECT, Log::Filter::Module::FINISH|CONTINUE) | ||||
142 | Arguments : string $source - Name of the source of the message | ||||
143 | enum $severity - Severity in integer or string format (see Log::Core::Essentials for permited values) | ||||
144 | string $message - Message | ||||
145 | Throws : Croaks, if invoked on class, or if given invalid arguments | ||||
146 | Comments : | ||||
147 | See Also : | ||||
148 | |||||
149 | =cut | ||||
150 | |||||
151 | sub accept($$$) { | ||||
152 | my $self = shift; | ||||
153 | croak ((caller(0))[3] . ": instance method invoked on class") unless ref $self; | ||||
154 | my ($source, $severity, $message) = @_; | ||||
155 | croak ((caller(0))[3] . ": invalid arguments") unless (defined($source) and defined($severity) and defined($message)); | ||||
156 | |||||
157 | my @fields = @_; | ||||
158 | my $resolution; | ||||
159 | my $continue; | ||||
160 | |||||
161 | # Walk through all PCRE patterns | ||||
162 | foreach my $pattern (@{$self->{PATTERNS}}) | ||||
163 | { | ||||
164 | # If the given field complies to the current pattern | ||||
165 | if (@fields[$self->{FIELD}] =~ /$pattern/) | ||||
166 | { | ||||
167 | unless ($self->{INVERT}) | ||||
168 | { | ||||
169 | $resolution = ACCEPT; | ||||
170 | $continue = ($self->{MODE} eq SUFFICIENT) ? FINISH : CONTINUE; | ||||
171 | } | ||||
172 | else { | ||||
173 | $resolution = REJECT; | ||||
174 | $continue = ($self->{MODE} eq REQUIRED) ? FINISH : CONTINUE; | ||||
175 | } | ||||
176 | return ($resolution, $continue); | ||||
177 | } | ||||
178 | } | ||||
179 | |||||
180 | unless ($self->{INVERT}) | ||||
181 | { | ||||
182 | $resolution = REJECT; | ||||
183 | $continue = ($self->{MODE} eq REQUIRED) ? FINISH : CONTINUE; | ||||
184 | } | ||||
185 | else { | ||||
186 | $resolution = ACCEPT; | ||||
187 | $continue = ($self->{MODE} eq SUFFICIENT) ? FINISH : CONTINUE; | ||||
188 | } | ||||
189 | return ($resolution, $continue); | ||||
190 | } | ||||
191 | |||||
192 | =item _init() [PROTECTED] | ||||
193 | |||||
194 | Usage : Used from constructor as follows: return $self->_init(@_); | ||||
195 | Purpose : Initialize newly created filter instance | ||||
196 | Returns : $self | ||||
197 | Arguments : enum $field - name of the field to test (source | severity | message) | ||||
198 | array reference $patterns - list of PCRE patterns | ||||
199 | string $flags - flags separated with spaces | ||||
200 | i - invert the result | ||||
201 | r - required | ||||
202 | Throws : Croaks, if invoked on class or invalid arguments given | ||||
203 | Comments : Internally used by parent`s new() method | ||||
204 | See Also : Log::Filter::Re->_init() method | ||||
205 | |||||
206 | =cut | ||||
207 | |||||
208 | sub _init { | ||||
209 | my $self = shift; | ||||
210 | croak ((caller(0))[3] . ": instance method invoked on class") unless ref $self; | ||||
211 | my ($field, $patterns, $flags) = @_; | ||||
212 | croak ((caller(0))[3] . ": invalid arguments") unless ($field and $patterns); | ||||
213 | |||||
214 | # First try to parse and init mandatory arguments | ||||
215 | $self->{FIELD} = $self->_field_int($field); | ||||
216 | $self->{PATTERNS} = []; | ||||
217 | my @ptrns; | ||||
218 | if(ref($patterns) eq 'ARRAY') { push(@ptrns, @{$patterns}); } | ||||
219 | else { push(@ptrns, $patterns); } | ||||
220 | push(@{$self->{PATTERNS}}, map { qr/$_/ } @ptrns); | ||||
221 | croak ((caller(0))[3] . ": invalid arguments") unless (defined($self->{FIELD}) and scalar @{$self->{PATTERNS}}); | ||||
222 | |||||
223 | # Set the engine flags to default falues | ||||
224 | $self->{MODE} = Log::Filter::Module::SUFFICIENT; | ||||
225 | $self->{INVERT} = 0; | ||||
226 | |||||
227 | # Setup the aditional engine flags | ||||
228 | if ($flags) | ||||
229 | { | ||||
230 | foreach my $flag (split(/[,; ]+/, $flags)) | ||||
231 | { | ||||
232 | if ($flag =~ /^r$|^req$/) { $self->{MODE} = Log::Filter::Module::REQUIRED; } | ||||
233 | elsif ($flag =~ /^i$|^inv$/) { $self->{INVERT} = 1; } | ||||
234 | else { croak ((caller(0))[3] . ": unknown flag '$flag'"); } | ||||
235 | } | ||||
236 | } | ||||
237 | return $self; | ||||
238 | } | ||||
239 | |||||
240 | =item _field_int($) [PROTECTED] | ||||
241 | |||||
242 | Usage : $self->_field_int($field) | ||||
243 | Purpose : Internal method for converting log field to integer index | ||||
244 | Returns : integer index | ||||
245 | Arguments : enum $field - name of the field to translate (source | severity | message) | ||||
246 | Throws : Croaks, if invoked on class | ||||
247 | Comments : Should be used only internally, used from _init() method | ||||
248 | See Also : | ||||
249 | |||||
250 | =cut | ||||
251 | |||||
252 | sub _field_int($) { | ||||
253 | my $self = shift; | ||||
254 | croak ((caller(0))[3] . ": instance method invoked on class") unless ref $self; | ||||
255 | my $field = uc(shift); | ||||
256 | |||||
257 | # Return undefined value if field was not specified | ||||
258 | return undef unless (defined($field)); | ||||
259 | |||||
260 | # Perform conversion only if the argument is not a number | ||||
261 | if ($field =~ /^$|[^\d]+/) | ||||
262 | { | ||||
263 | $field = $FIELD2INDEX{uc($field)}; | ||||
264 | } | ||||
265 | |||||
266 | # Return undefined value if the integer is not a valid field value | ||||
267 | return undef unless (defined($field) and defined($INDEX2FIELD[$field])); | ||||
268 | |||||
269 | # Othervise return valid value | ||||
270 | return $field; | ||||
271 | } | ||||
272 | |||||
273 | |||||
274 | =pod | ||||
275 | |||||
276 | =back | ||||
277 | |||||
278 | =cut | ||||
279 | |||||
280 | 1 | 4µs | 1; |