1# Copyrights 2007-2021 by [Mark Overmeer <markov@cpan.org>].
2#  For other contributors see ChangeLog.
3# See the manual pages for details on the licensing terms.
4# Pod stripped from pm file by OODoc 2.02.
5# This code is part of distribution Log-Report. Meta-POD processed with
6# OODoc into POD and HTML manual-pages.  See README.md
7# Copyright Mark Overmeer.  Licensed under the same terms as Perl itself.
8
9package Log::Report::Dispatcher;
10use vars '$VERSION';
11$VERSION = '1.33';
12
13
14use warnings;
15use strict;
16
17use Log::Report 'log-report';
18use Log::Report::Util qw/parse_locale expand_reasons %reason_code
19  escape_chars/;
20
21use POSIX      qw/strerror/;
22use List::Util qw/sum first/;
23use Encode     qw/find_encoding FB_DEFAULT/;
24use Devel::GlobalDestruction qw/in_global_destruction/;
25
26eval { POSIX->import('locale_h') };
27if($@)
28{   no strict 'refs';
29    *setlocale = sub { $_[1] }; *LC_ALL = sub { undef };
30}
31
32my %modes = (NORMAL => 0, VERBOSE => 1, ASSERT => 2, DEBUG => 3
33  , 0 => 0, 1 => 1, 2 => 2, 3 => 3);
34my @default_accept = ('NOTICE-', 'INFO-', 'ASSERT-', 'ALL');
35my %always_loc = map +($_ => 1), qw/ASSERT ALERT FAILURE PANIC/;
36
37my %predef_dispatchers = map +(uc($_) => __PACKAGE__.'::'.$_)
38  , qw/File Perl Syslog Try Callback Log4perl/;
39
40my @skip_stack = sub { $_[0][0] =~ m/^Log\:\:Report(?:\:\:|$)/ };
41
42
43sub new(@)
44{   my ($class, $type, $name, %args) = @_;
45
46    # $type is a class name or predefined name.
47    my $backend
48      = $predef_dispatchers{$type}          ? $predef_dispatchers{$type}
49      : $type->isa('Log::Dispatch::Output') ? __PACKAGE__.'::LogDispatch'
50      : $type;
51
52    eval "require $backend";
53    $@ and alert "cannot use class $backend:\n$@";
54
55    (bless {name => $name, type => $type, filters => []}, $backend)
56       ->init(\%args);
57}
58
59my %format_reason =
60  ( LOWERCASE => sub { lc $_[0] }
61  , UPPERCASE => sub { uc $_[0] }
62  , UCFIRST   => sub { ucfirst lc $_[0] }
63  , IGNORE    => sub { '' }
64  );
65
66my $default_mode = 'NORMAL';
67
68sub init($)
69{   my ($self, $args) = @_;
70
71    my $mode = $self->_set_mode(delete $args->{mode} || $default_mode);
72    $self->{locale} = delete $args->{locale};
73
74    my $accept = delete $args->{accept} || $default_accept[$mode];
75    $self->{needs}  = [ expand_reasons $accept ];
76
77    my $f = delete $args->{format_reason} || 'LOWERCASE';
78    $self->{format_reason} = ref $f eq 'CODE' ? $f : $format_reason{$f}
79        or error __x"illegal format_reason '{format}' for dispatcher",
80             format => $f;
81
82    my $csenc;
83    if(my $cs  = delete $args->{charset})
84    {   my $enc = find_encoding $cs
85            or error __x"Perl does not support charset {cs}", cs => $cs;
86        $csenc = sub { no warnings 'utf8'; $enc->encode($_[0]) };
87    }
88
89    $self->{charset_enc} = $csenc || sub { $_[0] };
90    $self;
91}
92
93
94sub close()
95{   my $self = shift;
96    $self->{closed}++ and return undef;
97    $self->{disabled}++;
98    $self;
99}
100
101sub DESTROY { in_global_destruction or shift->close }
102
103#----------------------------
104
105
106sub name {shift->{name}}
107
108
109sub type() {shift->{type}}
110
111
112sub mode() {shift->{mode}}
113
114#Please use C<dispatcher mode => $MODE;>
115sub defaultMode($) {$default_mode = $_[1]}
116
117# only to be used via Log::Report::dispatcher(mode => ...)
118# because requires re-investigating collective dispatcher needs
119sub _set_mode($)
120{   my $self = shift;
121    my $mode = $self->{mode} = $modes{$_[0]};
122    defined $mode or panic "unknown run mode $_[0]";
123
124    $self->{needs} = [ expand_reasons $default_accept[$mode] ];
125
126    trace __x"switching to run mode {mode} for {pkg}, accept {accept}"
127       , mode => $mode, pkg => ref $self, accept => $default_accept[$mode]
128         unless $self->isa('Log::Report::Dispatcher::Try');
129
130    $mode;
131}
132
133# only to be called from Log::Report::dispatcher()!!
134# because requires re-investigating needs
135sub _disabled($)
136{   my $self = shift;
137    @_ ? ($self->{disabled} = shift) : $self->{disabled};
138}
139
140
141sub isDisabled() {shift->{disabled}}
142
143
144sub needs(;$)
145{   my $self = shift;
146    return () if $self->{disabled};
147
148    my $needs = $self->{needs};
149    @_ or return @$needs;
150
151    my $need = shift;
152    first {$need eq $_} @$needs;
153}
154
155#-----------
156
157sub log($$$$)
158{   panic "method log() must be extended per back-end";
159}
160
161
162sub translate($$$)
163{   my ($self, $opts, $reason, $msg) = @_;
164
165    my $mode = $self->{mode};
166    my $code = $reason_code{$reason}
167        or panic "unknown reason '$reason'";
168
169    my $show_loc
170      = $always_loc{$reason}
171     || ($mode==2 && $code >= $reason_code{WARNING})
172     || ($mode==3 && $code >= $reason_code{MISTAKE});
173
174    my $show_stack
175      = $reason eq 'PANIC'
176     || ($mode==2 && $code >= $reason_code{ALERT})
177     || ($mode==3 && $code >= $reason_code{ERROR});
178
179    my $locale
180      = defined $msg->msgid
181      ? ($opts->{locale} || $self->{locale})      # translate whole
182      : (textdomain $msg->domain)->nativeLanguage;
183
184    my $oldloc = setlocale(&LC_ALL) // "";
185    setlocale(&LC_ALL, $locale)
186        if $locale && $locale ne $oldloc;
187
188    my $r = $self->{format_reason}->((__$reason)->toString);
189    my $e = $opts->{errno} ? strerror($opts->{errno}) : undef;
190
191    my $format
192      = $r && $e ? N__"{reason}: {message}; {error}"
193      : $r       ? N__"{reason}: {message}"
194      : $e       ? N__"{message}; {error}"
195      :            undef;
196
197    my $text
198      = ( defined $format
199        ? __x($format, message => $msg->toString , reason => $r, error => $e)
200        : $msg
201        )->toString;
202    $text =~ s/\n*\z/\n/;
203
204    if($show_loc)
205    {   if(my $loc = $opts->{location} || $self->collectLocation)
206        {   my ($pkg, $fn, $line, $sub) = @$loc;
207            # pkg and sub are missing when decoded by ::Die
208            $text .= " "
209                  . __x( 'at {filename} line {line}'
210                       , filename => $fn, line => $line)->toString
211                  . "\n";
212        }
213    }
214
215    if($show_stack)
216    {   my $stack = $opts->{stack} ||= $self->collectStack;
217        foreach (@$stack)
218        {   $text .= $_->[0] . " "
219              . __x( 'at {filename} line {line}'
220                   , filename => $_->[1], line => $_->[2] )->toString
221              . "\n";
222        }
223    }
224
225    setlocale(&LC_ALL, $oldloc)
226        if $locale && $locale ne $oldloc;
227
228    $self->{charset_enc}->($text);
229}
230
231
232sub collectStack($)
233{   my ($thing, $max) = @_;
234    my $nest = $thing->skipStack;
235
236    # special trick by Perl for Carp::Heavy: adds @DB::args
237  { package DB;    # non-blank before package to avoid problem with OODoc
238
239    my @stack;
240    while(!defined $max || $max--)
241    {   my ($pkg, $fn, $linenr, $sub) = caller $nest++;
242        defined $pkg or last;
243
244        my $line = $thing->stackTraceLine(call => $sub, params => \@DB::args);
245        push @stack, [$line, $fn, $linenr];
246    }
247
248    \@stack;
249  }
250}
251
252
253sub addSkipStack(@)
254{   my $thing = shift;
255    push @skip_stack, @_;
256    $thing;
257}
258
259
260sub skipStack()
261{   my $thing = shift;
262    my $nest  = 1;
263    my $args;
264
265    do { $args = [caller ++$nest] }
266    while @$args && first {$_->($args)} @skip_stack;
267
268    # do not count my own stack level in!
269    @$args ? $nest-1 : 1;
270}
271
272
273sub collectLocation() { [caller shift->skipStack] }
274
275
276sub stackTraceLine(@)
277{   my ($thing, %args) = @_;
278
279    my $max       = $args{max_line}   ||= 500;
280    my $abstract  = $args{abstract}   || 1;
281    my $maxparams = $args{max_params} || 8;
282    my @params    = @{$args{params}};
283    my $call      = $args{call};
284
285    my $obj = ref $params[0] && $call =~ m/^(.*\:\:)/ && UNIVERSAL::isa($params[0], $1)
286      ? shift @params : undef;
287
288    my $listtail  = '';
289    if(@params > $maxparams)
290    {   $listtail   = ', [' . (@params-$maxparams) . ' more]';
291        $#params  = $maxparams -1;
292    }
293
294    $max        -= @params * 2 - length($listtail);  #  \( ( \,[ ] ){n-1} \)
295
296    my $calling  = $thing->stackTraceCall(\%args, $abstract, $call, $obj);
297    my @out      = map $thing->stackTraceParam(\%args, $abstract, $_), @params;
298    my $total    = sum map {length $_} $calling, @out;
299
300  ATTEMPT:
301    while($total <= $max)
302    {   $abstract++;
303        last if $abstract > 2;  # later more levels
304
305        foreach my $p (reverse 0..$#out)
306        {   my $old  = $out[$p];
307            $out[$p] = $thing->stackTraceParam(\%args, $abstract, $params[$p]);
308            $total  -= length($old) - length($out[$p]);
309            last ATTEMPT if $total <= $max;
310        }
311
312        my $old   = $calling;
313        $calling  = $thing->stackTraceCall(\%args, $abstract, $call, $obj);
314        $total   -= length($old) - length($calling);
315    }
316
317    $calling .'(' . join(', ',@out) . $listtail . ')';
318}
319
320# 1: My::Object(0x123141, "my string")
321# 2: My::Object=HASH(0x1231451)
322# 3: My::Object("my string")
323# 4: My::Object()
324#
325
326sub stackTraceCall($$$;$)
327{   my ($thing, $args, $abstract, $call, $obj) = @_;
328
329    if(defined $obj)    # object oriented
330    {   my ($pkg, $method) = $call =~ m/^(.*\:\:)(.*)/;
331        return overload::StrVal($obj) . '->' . $call;
332    }
333    else                # imperative
334    {   return $call;
335    }
336}
337
338sub stackTraceParam($$$)
339{   my ($thing, $args, $abstract, $param) = @_;
340    defined $param
341        or return 'undef';
342
343    $param = overload::StrVal($param)
344        if ref $param;
345
346    return $param   # int or float
347        if $param =~ /^[+-]?(?:\d+(?:\.\d*)?|\.\d+)(?:[eE][+-]?\d+)?$/;
348
349    my $escaped = escape_chars $param;
350    if(length $escaped > 80)
351    {    $escaped = substr($escaped, 0, 30)
352                  . '...['. (length($escaped) -80) .' chars more]...'
353                  . substr($escaped, -30);
354    }
355
356    qq{"$escaped"};
357}
358
359#------------
360
3611;
362