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