362 lines
9.3 KiB
Perl
362 lines
9.3 KiB
Perl
# Copyrights 2007-2021 by [Mark Overmeer <markov@cpan.org>].
|
|
# For other contributors see ChangeLog.
|
|
# See the manual pages for details on the licensing terms.
|
|
# Pod stripped from pm file by OODoc 2.02.
|
|
# This code is part of distribution Log-Report. Meta-POD processed with
|
|
# OODoc into POD and HTML manual-pages. See README.md
|
|
# Copyright Mark Overmeer. Licensed under the same terms as Perl itself.
|
|
|
|
package Log::Report::Dispatcher;
|
|
use vars '$VERSION';
|
|
$VERSION = '1.31';
|
|
|
|
|
|
use warnings;
|
|
use strict;
|
|
|
|
use Log::Report 'log-report';
|
|
use Log::Report::Util qw/parse_locale expand_reasons %reason_code
|
|
escape_chars/;
|
|
|
|
use POSIX qw/strerror/;
|
|
use List::Util qw/sum first/;
|
|
use Encode qw/find_encoding FB_DEFAULT/;
|
|
use Devel::GlobalDestruction qw/in_global_destruction/;
|
|
|
|
eval { POSIX->import('locale_h') };
|
|
if($@)
|
|
{ no strict 'refs';
|
|
*setlocale = sub { $_[1] }; *LC_ALL = sub { undef };
|
|
}
|
|
|
|
my %modes = (NORMAL => 0, VERBOSE => 1, ASSERT => 2, DEBUG => 3
|
|
, 0 => 0, 1 => 1, 2 => 2, 3 => 3);
|
|
my @default_accept = ('NOTICE-', 'INFO-', 'ASSERT-', 'ALL');
|
|
my %always_loc = map +($_ => 1), qw/ASSERT ALERT FAILURE PANIC/;
|
|
|
|
my %predef_dispatchers = map +(uc($_) => __PACKAGE__.'::'.$_)
|
|
, qw/File Perl Syslog Try Callback Log4perl/;
|
|
|
|
my @skip_stack = sub { $_[0][0] =~ m/^Log\:\:Report(?:\:\:|$)/ };
|
|
|
|
|
|
sub new(@)
|
|
{ my ($class, $type, $name, %args) = @_;
|
|
|
|
# $type is a class name or predefined name.
|
|
my $backend
|
|
= $predef_dispatchers{$type} ? $predef_dispatchers{$type}
|
|
: $type->isa('Log::Dispatch::Output') ? __PACKAGE__.'::LogDispatch'
|
|
: $type;
|
|
|
|
eval "require $backend";
|
|
$@ and alert "cannot use class $backend:\n$@";
|
|
|
|
(bless {name => $name, type => $type, filters => []}, $backend)
|
|
->init(\%args);
|
|
}
|
|
|
|
my %format_reason =
|
|
( LOWERCASE => sub { lc $_[0] }
|
|
, UPPERCASE => sub { uc $_[0] }
|
|
, UCFIRST => sub { ucfirst lc $_[0] }
|
|
, IGNORE => sub { '' }
|
|
);
|
|
|
|
my $default_mode = 'NORMAL';
|
|
|
|
sub init($)
|
|
{ my ($self, $args) = @_;
|
|
|
|
my $mode = $self->_set_mode(delete $args->{mode} || $default_mode);
|
|
$self->{locale} = delete $args->{locale};
|
|
|
|
my $accept = delete $args->{accept} || $default_accept[$mode];
|
|
$self->{needs} = [ expand_reasons $accept ];
|
|
|
|
my $f = delete $args->{format_reason} || 'LOWERCASE';
|
|
$self->{format_reason} = ref $f eq 'CODE' ? $f : $format_reason{$f}
|
|
or error __x"illegal format_reason '{format}' for dispatcher",
|
|
format => $f;
|
|
|
|
my $csenc;
|
|
if(my $cs = delete $args->{charset})
|
|
{ my $enc = find_encoding $cs
|
|
or error __x"Perl does not support charset {cs}", cs => $cs;
|
|
$csenc = sub { no warnings 'utf8'; $enc->encode($_[0]) };
|
|
}
|
|
|
|
$self->{charset_enc} = $csenc || sub { $_[0] };
|
|
$self;
|
|
}
|
|
|
|
|
|
sub close()
|
|
{ my $self = shift;
|
|
$self->{closed}++ and return undef;
|
|
$self->{disabled}++;
|
|
$self;
|
|
}
|
|
|
|
sub DESTROY { in_global_destruction or shift->close }
|
|
|
|
#----------------------------
|
|
|
|
|
|
sub name {shift->{name}}
|
|
|
|
|
|
sub type() {shift->{type}}
|
|
|
|
|
|
sub mode() {shift->{mode}}
|
|
|
|
#Please use C<dispatcher mode => $MODE;>
|
|
sub defaultMode($) {$default_mode = $_[1]}
|
|
|
|
# only to be used via Log::Report::dispatcher(mode => ...)
|
|
# because requires re-investigating collective dispatcher needs
|
|
sub _set_mode($)
|
|
{ my $self = shift;
|
|
my $mode = $self->{mode} = $modes{$_[0]};
|
|
defined $mode or panic "unknown run mode $_[0]";
|
|
|
|
$self->{needs} = [ expand_reasons $default_accept[$mode] ];
|
|
|
|
trace __x"switching to run mode {mode} for {pkg}, accept {accept}"
|
|
, mode => $mode, pkg => ref $self, accept => $default_accept[$mode]
|
|
unless $self->isa('Log::Report::Dispatcher::Try');
|
|
|
|
$mode;
|
|
}
|
|
|
|
# only to be called from Log::Report::dispatcher()!!
|
|
# because requires re-investigating needs
|
|
sub _disabled($)
|
|
{ my $self = shift;
|
|
@_ ? ($self->{disabled} = shift) : $self->{disabled};
|
|
}
|
|
|
|
|
|
sub isDisabled() {shift->{disabled}}
|
|
|
|
|
|
sub needs(;$)
|
|
{ my $self = shift;
|
|
return () if $self->{disabled};
|
|
|
|
my $needs = $self->{needs};
|
|
@_ or return @$needs;
|
|
|
|
my $need = shift;
|
|
first {$need eq $_} @$needs;
|
|
}
|
|
|
|
#-----------
|
|
|
|
sub log($$$$)
|
|
{ panic "method log() must be extended per back-end";
|
|
}
|
|
|
|
|
|
sub translate($$$)
|
|
{ my ($self, $opts, $reason, $msg) = @_;
|
|
|
|
my $mode = $self->{mode};
|
|
my $code = $reason_code{$reason}
|
|
or panic "unknown reason '$reason'";
|
|
|
|
my $show_loc
|
|
= $always_loc{$reason}
|
|
|| ($mode==2 && $code >= $reason_code{WARNING})
|
|
|| ($mode==3 && $code >= $reason_code{MISTAKE});
|
|
|
|
my $show_stack
|
|
= $reason eq 'PANIC'
|
|
|| ($mode==2 && $code >= $reason_code{ALERT})
|
|
|| ($mode==3 && $code >= $reason_code{ERROR});
|
|
|
|
my $locale
|
|
= defined $msg->msgid
|
|
? ($opts->{locale} || $self->{locale}) # translate whole
|
|
: (textdomain $msg->domain)->nativeLanguage;
|
|
|
|
my $oldloc = setlocale(&LC_ALL) // "";
|
|
setlocale(&LC_ALL, $locale)
|
|
if $locale && $locale ne $oldloc;
|
|
|
|
my $r = $self->{format_reason}->((__$reason)->toString);
|
|
my $e = $opts->{errno} ? strerror($opts->{errno}) : undef;
|
|
|
|
my $format
|
|
= $r && $e ? N__"{reason}: {message}; {error}"
|
|
: $r ? N__"{reason}: {message}"
|
|
: $e ? N__"{message}; {error}"
|
|
: undef;
|
|
|
|
my $text
|
|
= ( defined $format
|
|
? __x($format, message => $msg->toString , reason => $r, error => $e)
|
|
: $msg
|
|
)->toString;
|
|
$text =~ s/\n*\z/\n/;
|
|
|
|
if($show_loc)
|
|
{ if(my $loc = $opts->{location} || $self->collectLocation)
|
|
{ my ($pkg, $fn, $line, $sub) = @$loc;
|
|
# pkg and sub are missing when decoded by ::Die
|
|
$text .= " "
|
|
. __x( 'at {filename} line {line}'
|
|
, filename => $fn, line => $line)->toString
|
|
. "\n";
|
|
}
|
|
}
|
|
|
|
if($show_stack)
|
|
{ my $stack = $opts->{stack} ||= $self->collectStack;
|
|
foreach (@$stack)
|
|
{ $text .= $_->[0] . " "
|
|
. __x( 'at {filename} line {line}'
|
|
, filename => $_->[1], line => $_->[2] )->toString
|
|
. "\n";
|
|
}
|
|
}
|
|
|
|
setlocale(&LC_ALL, $oldloc)
|
|
if $locale && $locale ne $oldloc;
|
|
|
|
$self->{charset_enc}->($text);
|
|
}
|
|
|
|
|
|
sub collectStack($)
|
|
{ my ($thing, $max) = @_;
|
|
my $nest = $thing->skipStack;
|
|
|
|
# special trick by Perl for Carp::Heavy: adds @DB::args
|
|
{ package DB; # non-blank before package to avoid problem with OODoc
|
|
|
|
my @stack;
|
|
while(!defined $max || $max--)
|
|
{ my ($pkg, $fn, $linenr, $sub) = caller $nest++;
|
|
defined $pkg or last;
|
|
|
|
my $line = $thing->stackTraceLine(call => $sub, params => \@DB::args);
|
|
push @stack, [$line, $fn, $linenr];
|
|
}
|
|
|
|
\@stack;
|
|
}
|
|
}
|
|
|
|
|
|
sub addSkipStack(@)
|
|
{ my $thing = shift;
|
|
push @skip_stack, @_;
|
|
$thing;
|
|
}
|
|
|
|
|
|
sub skipStack()
|
|
{ my $thing = shift;
|
|
my $nest = 1;
|
|
my $args;
|
|
|
|
do { $args = [caller ++$nest] }
|
|
while @$args && first {$_->($args)} @skip_stack;
|
|
|
|
# do not count my own stack level in!
|
|
@$args ? $nest-1 : 1;
|
|
}
|
|
|
|
|
|
sub collectLocation() { [caller shift->skipStack] }
|
|
|
|
|
|
sub stackTraceLine(@)
|
|
{ my ($thing, %args) = @_;
|
|
|
|
my $max = $args{max_line} ||= 500;
|
|
my $abstract = $args{abstract} || 1;
|
|
my $maxparams = $args{max_params} || 8;
|
|
my @params = @{$args{params}};
|
|
my $call = $args{call};
|
|
|
|
my $obj = ref $params[0] && $call =~ m/^(.*\:\:)/ && UNIVERSAL::isa($params[0], $1)
|
|
? shift @params : undef;
|
|
|
|
my $listtail = '';
|
|
if(@params > $maxparams)
|
|
{ $listtail = ', [' . (@params-$maxparams) . ' more]';
|
|
$#params = $maxparams -1;
|
|
}
|
|
|
|
$max -= @params * 2 - length($listtail); # \( ( \,[ ] ){n-1} \)
|
|
|
|
my $calling = $thing->stackTraceCall(\%args, $abstract, $call, $obj);
|
|
my @out = map $thing->stackTraceParam(\%args, $abstract, $_), @params;
|
|
my $total = sum map {length $_} $calling, @out;
|
|
|
|
ATTEMPT:
|
|
while($total <= $max)
|
|
{ $abstract++;
|
|
last if $abstract > 2; # later more levels
|
|
|
|
foreach my $p (reverse 0..$#out)
|
|
{ my $old = $out[$p];
|
|
$out[$p] = $thing->stackTraceParam(\%args, $abstract, $params[$p]);
|
|
$total -= length($old) - length($out[$p]);
|
|
last ATTEMPT if $total <= $max;
|
|
}
|
|
|
|
my $old = $calling;
|
|
$calling = $thing->stackTraceCall(\%args, $abstract, $call, $obj);
|
|
$total -= length($old) - length($calling);
|
|
}
|
|
|
|
$calling .'(' . join(', ',@out) . $listtail . ')';
|
|
}
|
|
|
|
# 1: My::Object(0x123141, "my string")
|
|
# 2: My::Object=HASH(0x1231451)
|
|
# 3: My::Object("my string")
|
|
# 4: My::Object()
|
|
#
|
|
|
|
sub stackTraceCall($$$;$)
|
|
{ my ($thing, $args, $abstract, $call, $obj) = @_;
|
|
|
|
if(defined $obj) # object oriented
|
|
{ my ($pkg, $method) = $call =~ m/^(.*\:\:)(.*)/;
|
|
return overload::StrVal($obj) . '->' . $call;
|
|
}
|
|
else # imperative
|
|
{ return $call;
|
|
}
|
|
}
|
|
|
|
sub stackTraceParam($$$)
|
|
{ my ($thing, $args, $abstract, $param) = @_;
|
|
defined $param
|
|
or return 'undef';
|
|
|
|
$param = overload::StrVal($param)
|
|
if ref $param;
|
|
|
|
return $param # int or float
|
|
if $param =~ /^[+-]?(?:\d+(?:\.\d*)?|\.\d+)(?:[eE][+-]?\d+)?$/;
|
|
|
|
my $escaped = escape_chars $param;
|
|
if(length $escaped > 80)
|
|
{ $escaped = substr($escaped, 0, 30)
|
|
. '...['. (length($escaped) -80) .' chars more]...'
|
|
. substr($escaped, -30);
|
|
}
|
|
|
|
qq{"$escaped"};
|
|
}
|
|
|
|
#------------
|
|
|
|
1;
|