File Coverage

File:blib/lib/Log/WarnDie.pm
Coverage:58.8%

linestmtbrancondsubtimecode
1package 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
15our $DISPATCHER;
16our $FILTER;
17our $STDERR;
18our $LAST;
19
20# Old settings of standard Perl logging mechanisms
21
22our $WARN;
23our $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
27our $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
103our $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# PRINT
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
132sub 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} #PRINT
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
164sub 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
199sub 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
220sub 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
240BEGIN {
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
340sub 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
380sub 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
4791;