File: | blib/lib/Log/WarnDie.pm |
Coverage: | 58.8% |
line | stmt | bran | cond | sub | time | code |
---|---|---|---|---|---|---|
1 | package Log::WarnDie; | |||||
2 | ||||||
3 | 4 4 4 | 457139 4 83 | use warnings; | |||
4 | 4 4 4 | 9 3 37 | use strict; | |||
5 | ||||||
6 | # Make sure we have the modules that we need | |||||
7 | ||||||
8 | 4 4 4 | 886 9955 51 | use IO::Handle (); | |||
9 | 4 4 4 | 8 4 1556 | use Scalar::Util qw(blessed); | |||
10 | ||||||
11 | # The logging dispatcher that should be used | |||||
12 | # The (original) error output handle | |||||
13 | # Reference to the previous parameters sent | |||||
14 | ||||||
15 | our $DISPATCHER; | |||||
16 | our $FILTER; | |||||
17 | our $STDERR; | |||||
18 | our $LAST; | |||||
19 | ||||||
20 | # Old settings of standard Perl logging mechanisms | |||||
21 | ||||||
22 | our $WARN; | |||||
23 | our $DIE; | |||||
24 | ||||||
25 | # Handle the situation when the logger you hand to Log::WarnDie is (directly or indirectly) writing to STDERR, which this module has tied. | |||||
26 | # That causes the tied PRINT/PRINTF/__WARN__ handler to call the dispatcher again which writes to STDERR and you end up with deep recursion | |||||
27 | our $IN_LOG; # false normally, true while we're inside a logging call | |||||
28 | ||||||
29 - 101 | =head1 NAME Log::WarnDie - Log standard Perl warnings and errors on a log handler =head1 VERSION Version 0.12 =head1 SYNOPSIS use Log::WarnDie; # install to be used later use Log::Dispatch; use Log::Dispatch::Email::Sendmail; my $dispatcher = Log::Dispatch->new(); # can be any dispatcher! $dispatcher->add( Log::Dispatch::Email::Sendmail->new( # whatever output you like name => 'foo', min_level => 'info', ) ); use Log::WarnDie $dispatcher; # activate later Log::WarnDie->dispatcher( $dispatcher ); # same warn "This is a warning"; # now also dispatched die "Sorry it didn't work out"; # now also dispatched Log::WarnDie->dispatcher(undef); # deactivate Log::WarnDie->filter(\&filter); warn "This is a warning"; # no longer dispatched die "Sorry it didn't work out"; # no longer dispatched # Filter out File::stat noise sub filter { return 0 if($_[0] != /^S_IFFIFO is not a valid Fcntl macro/); } =head1 DESCRIPTION The C<Log::WarnDie> module offers a logging alternative for standard Perl core functions. This allows you to use the features of e.g. L<Log::Dispatch>, L<Log::Any> or L<Log::Log4perl> B<without> having to make extensive changes to your source code. When loaded, it installs a __WARN__ and __DIE__ handler and intercepts any output to STDERR. It also takes over the messaging functions of L<Carp>. Without being further activated, the standard Perl logging functions continue to be executed: e.g. if you expect warnings to appear on STDERR, they will. Then, when necessary, you can activate actual logging through e.g. Log::Dispatch by installing a log dispatcher. From then on, any warn, die, carp, croak, cluck, confess or print to the STDERR handle, will be logged using the Log::Dispatch logging dispatcher. Logging can be disabled and enabled at any time for critical sections of code. The following log levels are used: =head2 warning Any C<warn>, C<Carp::carp> or C<Carp::cluck> will generate a "warning" level message. =head2 error Any direct output to STDERR will generate an "error" level message. =head2 critical Any C<die>, C<Carp::croak> or C<Carp::confess> will generate a "critical" level message. =cut | |||||
102 | ||||||
103 | our $VERSION = '0.12'; | |||||
104 | ||||||
105 - 107 | =head1 SUBROUTINES/METHODS =cut | |||||
108 | ||||||
109 | #--------------------------------------------------------------------------- | |||||
110 | ||||||
111 | # Tie subroutines need to be known at compile time, hence there here, near | |||||
112 | # the start of code rather than near the end where these would normally live. | |||||
113 | ||||||
114 | #--------------------------------------------------------------------------- | |||||
115 | # TIEHANDLE | |||||
116 | # | |||||
117 | # Called whenever a dispatcher is activated | |||||
118 | # | |||||
119 | # IN: 1 class with which to bless | |||||
120 | # OUT: 1 blessed object | |||||
121 | ||||||
122 | 4 | 7 | sub TIEHANDLE { bless \"$_[0]",$_[0] } #TIEHANDLE | |||
123 | ||||||
124 | #--------------------------------------------------------------------------- | |||||
125 | ||||||
126 | # | |||||
127 | # Called whenever something is printed on STDERR | |||||
128 | # | |||||
129 | # IN: 1 blessed object returned by TIEHANDLE | |||||
130 | # 2..N whatever was needed to be printed | |||||
131 | ||||||
132 | sub PRINT | |||||
133 | { | |||||
134 | # Lose the object | |||||
135 | # If there is a dispatcher | |||||
136 | # Put it in the log handler if not the same as last time | |||||
137 | # Reset the flag | |||||
138 | # Make sure it appears on the original STDERR as well | |||||
139 | ||||||
140 | 4 | 8 | return if $IN_LOG; # prevents re-entry | |||
141 | 4 | 6 | shift; | |||
142 | 4 | 3 | if($FILTER) { | |||
143 | 2 | 3 | return if($FILTER->(@_) == 0); | |||
144 | } | |||||
145 | 4 | 9 | if ($DISPATCHER) { | |||
146 | # Prevent deep recursion | |||||
147 | 3 | 3 | local $IN_LOG = 1; | |||
148 | 3 | 11 | $DISPATCHER->error( @_ ) unless $LAST and @$LAST == @_ and join( '',@$LAST ) eq join( '',@_ ); | |||
149 | 3 | 48 | undef $LAST; | |||
150 | } | |||||
151 | 4 | 9 | if($STDERR) { | |||
152 | 4 | 22 | print $STDERR @_; | |||
153 | } | |||||
154 | ||||||
155 | ||||||
156 | #--------------------------------------------------------------------------- | |||||
157 | # PRINTF | |||||
158 | # | |||||
159 | # Called whenever something is printed on STDERR using printf | |||||
160 | # | |||||
161 | # IN: 1 blessed object returned by TIEHANDLE | |||||
162 | # 2..N whatever was needed to be printed | |||||
163 | ||||||
164 | sub PRINTF { | |||||
165 | ||||||
166 | # Lose the object | |||||
167 | # If there is a dispatcher | |||||
168 | # Put it in the log handler if not the same as last time | |||||
169 | # Reset the flag | |||||
170 | # Make sure it appears on the original STDERR as well | |||||
171 | ||||||
172 | 1 | 3 | return if $IN_LOG; # prevents re-entry | |||
173 | 1 | 1 | shift; | |||
174 | 1 | 1 | my $format = shift; | |||
175 | 1 | 1 | my @args = @_; | |||
176 | 1 | 35 | return if(scalar(@args) == 0); | |||
177 | 0 | 0 | if($FILTER) { | |||
178 | 0 | 0 | return if($FILTER->(sprintf($format, @args)) == 0); | |||
179 | } | |||||
180 | 0 | 0 | if ($DISPATCHER) { | |||
181 | 0 | 0 | local $IN_LOG = 1; | |||
182 | 0 | 0 | $DISPATCHER->error(sprintf($format, @args)) | |||
183 | unless $LAST and @$LAST == @args and join( '',@$LAST ) eq join( '',@args ); | |||||
184 | 0 | 0 | undef $LAST; | |||
185 | } | |||||
186 | 0 | 0 | if($STDERR) { | |||
187 | 0 | 0 | printf $STDERR $format, @args; | |||
188 | } | |||||
189 | } #PRINTF | |||||
190 | ||||||
191 | #--------------------------------------------------------------------------- | |||||
192 | # CLOSE | |||||
193 | # | |||||
194 | # Called whenever something tries to close STDERR | |||||
195 | # | |||||
196 | # IN: 1 blessed object returned by TIEHANDLE | |||||
197 | # 2..N whatever was needed to be printed | |||||
198 | ||||||
199 | sub CLOSE { | |||||
200 | ||||||
201 | # Lose the object | |||||
202 | # If there is a dispatcher | |||||
203 | # Put it in the log handler if not the same as last time | |||||
204 | # Reset the flag | |||||
205 | # Make sure it appears on the original STDERR as well | |||||
206 | ||||||
207 | 0 | 0 | my $keep = $STDERR; | |||
208 | 0 | 0 | $STDERR = undef; | |||
209 | 0 | 0 | close $keep; # So that the return status can be checked | |||
210 | } #CLOSE | |||||
211 | ||||||
212 | #--------------------------------------------------------------------------- | |||||
213 | # OPEN | |||||
214 | # | |||||
215 | # Called whenever something tries to (re)open STDERR | |||||
216 | # | |||||
217 | # IN: 1 blessed object returned by TIEHANDLE | |||||
218 | # 2..N whatever was needed to be printed | |||||
219 | ||||||
220 | sub OPEN { | |||||
221 | ||||||
222 | # Lose the object | |||||
223 | # If there is a dispatcher | |||||
224 | # Put it in the log handler if not the same as last time | |||||
225 | # Reset the flag | |||||
226 | # Make sure it appears on the original STDERR as well | |||||
227 | ||||||
228 | 0 | 0 | shift; | |||
229 | 0 | 0 | my $arg1 = shift; | |||
230 | 0 | 0 | my $arg2 = shift; | |||
231 | ||||||
232 | 0 | 0 | open($STDERR, $arg1, $arg2); | |||
233 | } #OPEN | |||||
234 | #--------------------------------------------------------------------------- | |||||
235 | # At compile time | |||||
236 | # Create new handle | |||||
237 | # Make sure it's the same as the current STDERR | |||||
238 | # Make sure the original STDERR is now handled by our sub | |||||
239 | ||||||
240 | BEGIN { | |||||
241 | 4 | 10 | $STDERR = IO::Handle->new(); | |||
242 | 4 | 48 | $STDERR->fdopen(fileno(STDERR), 'w') or die "Could not open STDERR 2nd time: $!\n"; | |||
243 | 4 | 107 | tie *STDERR,__PACKAGE__; | |||
244 | ||||||
245 | # Save current __WARN__ setting | |||||
246 | # Replace it with a sub that | |||||
247 | # If there is a dispatcher | |||||
248 | # Remembers the last parameters | |||||
249 | # Dispatches a warning message | |||||
250 | # Executes the standard system warn() or whatever was there before | |||||
251 | ||||||
252 | 4 | 4 | $WARN = $SIG{__WARN__}; | |||
253 | $SIG{__WARN__} = sub { | |||||
254 | 4 | 21 | if($FILTER) { | |||
255 | 3 | 3 | if($FILTER->(@_) == 0) { | |||
256 | # $WARN ? $WARN->( @_ ) : CORE::warn( @_ ); | |||||
257 | 1 | 4 | return; | |||
258 | } | |||||
259 | } | |||||
260 | # Avoid 'Can't call method \"log\" on an undefined value' during the destroy phase | |||||
261 | 3 | 22 | if(defined($^V) && ($^V ge 'v5.14.0')) { | |||
262 | 3 | 5 | if(${^GLOBAL_PHASE} eq 'DESTRUCT') { # >= 5.14.0 only | |||
263 | 0 | 0 | CORE::warn(@_); | |||
264 | 0 | 0 | return; | |||
265 | } | |||||
266 | } | |||||
267 | 3 | 4 | if ($DISPATCHER) { | |||
268 | 2 | 3 | $LAST = \@_; | |||
269 | 2 | 4 | if(ref($DISPATCHER) =~ /^Log::Log4perl/) { | |||
270 | 0 | 0 | $DISPATCHER->warn( @_ ); | |||
271 | } else { | |||||
272 | 2 | 6 | $DISPATCHER->warning( @_ ); | |||
273 | } | |||||
274 | } | |||||
275 | 3 | 84 | $WARN ? $WARN->( @_ ) : CORE::warn( @_ ); | |||
276 | 4 | 12 | }; | |||
277 | ||||||
278 | # Save current __DIE__ setting | |||||
279 | # Replace it with a sub that | |||||
280 | # If there is a dispatcher | |||||
281 | # Remembers the last parameters | |||||
282 | # Dispatches a critical message | |||||
283 | # Executes the standard system die() or whatever was there before | |||||
284 | ||||||
285 | 4 | 7 | $DIE = $SIG{__DIE__}; | |||
286 | $SIG{__DIE__} = sub { | |||||
287 | 1 | 667 | if ($DISPATCHER) { | |||
288 | 1 | 1 | if($FILTER) { | |||
289 | 0 | 0 | if($FILTER->(@_) == 0) { | |||
290 | 0 | 0 | if($DIE) { | |||
291 | # $DIE->(@_); | |||||
292 | 0 | 0 | $DIE->(); | |||
293 | } else { | |||||
294 | 0 | 0 | return unless((defined $^S) && ($^S == 0)); # Ignore errors in eval | |||
295 | # CORE::die(@_); | |||||
296 | 0 | 0 | CORE::die; | |||
297 | } | |||||
298 | } | |||||
299 | } | |||||
300 | 1 | 2 | $LAST = \@_; | |||
301 | 1 | 2 | if(ref($DISPATCHER) =~ /^Log::Log4perl/) { | |||
302 | 0 | 0 | $DISPATCHER->fatal( @_ ); | |||
303 | } else { | |||||
304 | 1 | 3 | $DISPATCHER->critical( @_ ); | |||
305 | } | |||||
306 | } | |||||
307 | # Handle http://stackoverflow.com/questions/8078220/custom-error-handling-is-catching-errors-that-normally-are-not-displayed | |||||
308 | # $DIE ? $DIE->( @_ ) : CORE::die( @_ ); | |||||
309 | 1 | 53 | if($DIE) { | |||
310 | 0 | 0 | $DIE->(@_); | |||
311 | } else { | |||||
312 | 1 | 5 | return unless((defined $^S) && ($^S == 0)); # Ignore errors in eval | |||
313 | 0 | 0 | CORE::die(@_); | |||
314 | } | |||||
315 | 4 | 9 | }; | |||
316 | ||||||
317 | # Make sure we won't be listed ourselves by Carp:: | |||||
318 | ||||||
319 | 4 | 457 | $Carp::Internal{__PACKAGE__} = 1; | |||
320 | } #BEGIN | |||||
321 | ||||||
322 | # Satisfy require | |||||
323 | ||||||
324 | #--------------------------------------------------------------------------- | |||||
325 | ||||||
326 | # Class methods | |||||
327 | ||||||
328 | #--------------------------------------------------------------------------- | |||||
329 | ||||||
330 - 338 | =head2 dispatcher Class method to set and/or return the current dispatcher # IN: 1 class (ignored) # 2 new dispatcher (optional) # OUT: 1 current dispatcher =cut | |||||
339 | ||||||
340 | sub dispatcher | |||||
341 | { | |||||
342 | # Return the current dispatcher if no changes needed | |||||
343 | # Set the new dispatcher | |||||
344 | ||||||
345 | 7 | 173971 | return $DISPATCHER if(scalar(@_) <= 1); | |||
346 | 3 | 4 | $DISPATCHER = $_[1]; | |||
347 | ||||||
348 | # If there is a dispatcher now | |||||
349 | # If the dispatcher is a Log::Dispatch er | |||||
350 | # Make sure all of standard Log::Dispatch stuff becomes invisible for Carp:: | |||||
351 | # If there are outputs already | |||||
352 | # Make sure all of the output objects become invisible for Carp:: | |||||
353 | ||||||
354 | 3 | 4 | if ($DISPATCHER) { | |||
355 | 2 | 5 | if($DISPATCHER->isa( 'Log::Dispatch')) { | |||
356 | $Carp::Internal{$_} = 1 | |||||
357 | 2 | 8 | foreach 'Log::Dispatch','Log::Dispatch::Output'; | |||
358 | 2 | 2 | if(my $outputs = $DISPATCHER->{'outputs'}) { | |||
359 | $Carp::Internal{$_} = 1 | |||||
360 | 2 2 2 | 3 7 3 | foreach map {blessed $_} values %{$outputs}; | |||
361 | } | |||||
362 | } | |||||
363 | } | |||||
364 | ||||||
365 | # Return the current dispatcher | |||||
366 | ||||||
367 | 3 | 2 | return $DISPATCHER; | |||
368 | } #dispatcher | |||||
369 | ||||||
370 - 378 | =head2 filter Class method to set and/or get the current output filter The given callback function should return 1 to output the given message, or 0 to drop it. Useful for noisy messages such as File::stat giving S_IFFIFO is not a valid Fcntl macro. =cut | |||||
379 | ||||||
380 | sub filter { | |||||
381 | 1 | 486 | return $FILTER if(scalar(@_) <= 1); | |||
382 | 1 | 1 | $FILTER = $_[1]; | |||
383 | } | |||||
384 | ||||||
385 | #--------------------------------------------------------------------------- | |||||
386 | ||||||
387 | # Perl standard features | |||||
388 | ||||||
389 | #--------------------------------------------------------------------------- | |||||
390 | # import | |||||
391 | # | |||||
392 | # Called whenever a -use- is done. | |||||
393 | # | |||||
394 | # IN: 1 class (ignored) | |||||
395 | # 2 new dispatcher (optional) | |||||
396 | ||||||
397 | *import = \&dispatcher; | |||||
398 | ||||||
399 | #--------------------------------------------------------------------------- | |||||
400 | # unimport | |||||
401 | # | |||||
402 | # Called whenever a -use- is done. | |||||
403 | # | |||||
404 | # IN: 1 class (ignored) | |||||
405 | ||||||
406 | 0 | sub unimport { import( undef ) } #unimport | ||||
407 | ||||||
408 | #--------------------------------------------------------------------------- | |||||
409 | ||||||
410 - 477 | =head1 AUTHOR Elizabeth Mattijsen, <liz@dijkmat.nl> Maintained by Nigel Horne, C<< <njh at nigelhorne.com> >> =head1 BUGS This module is provided as-is without any warranty. Please report any bugs or feature requests to C<bug-log-warndie at rt.cpan.org>, or through the web interface at L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Log-WarnDie>. I will be notified, and then you'll automatically be notified of progress on your bug as I make changes. =head1 CAVEATS The following caveats may apply to your situation. =head2 Associated modules Although a module such as L<Log::Dispatch> is B<not> listed as a prerequisite, the real use of this module only comes into view when such a module B<is> installed. Please note that for testing this module, you will need the L<Log::Dispatch::Buffer> module to also be available. This module has been tested with L<Log::Dispatch>, L<Log::Any> and L<Log::Log4perl>. In principle, any object which recognises C<warning>, C<error> and C<critical> should work. =head2 eval In the current implementation of Perl, a __DIE__ handler is B<also> called inside an eval. Whereas a normal C<die> would just exit the eval, the __DIE__ handler _will_ get called inside the eval. Which may or may not be what you want. To prevent the __DIE__ handler from being called inside eval's, add the following line to the eval block or string being evaluated: local $SIG{__DIE__} = undef; This disables the __DIE__ handler within the evalled block or string, and will automatically enable it again upon exit of the evalled block or string. Unfortunately, there is no automatic way to do that for you. =head1 SEE ALSO =over 4 =item * Test coverage report: L<https://nigelhorne.github.io/Log-WarnDie/coverage/> =back =head1 COPYRIGHT Copyright (c) 2004, 2007 Elizabeth Mattijsen <liz@dijkmat.nl>. All rights reserved. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. Portions of versions 0.06 onwards, Copyright 2017-2024 Nigel Horne =cut | |||||
478 | ||||||
479 | 1; |