# This code is part of Perl distribution Log-Report version 1.41.
# The POD got stripped from this file by OODoc version 3.04.
# For contributors see file ChangeLog.

# This software is copyright (c) 2007-2025 by Mark Overmeer.

# This is free software; you can redistribute it and/or modify it under
# the same terms as the Perl 5 programming language system itself.
# SPDX-License-Identifier: Artistic-1.0-Perl OR GPL-1.0-or-later

#oodist: *** DO NOT USE THIS VERSION FOR PRODUCTION ***
#oodist: This file contains OODoc-style documentation which will get stripped
#oodist: during its release in the distribution.  You can use this file for
#oodist: testing, however the code of this development version may be broken!

#oorestyle: not found P for method type($type)

# 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;{
our $VERSION = '1.41';
}


use warnings;
use strict;

use Log::Report 'log-report';
use Log::Report::Util qw/parse_locale expand_reasons %reason_code escape_chars use_errno/;

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 { $_[0]->{name} }


sub type() { $_[0]->{type} }


sub mode() { $_[0]->{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] ];

	$self->isa('Log::Report::Dispatcher::Try')
		or trace __x"switching to run mode {mode} for {pkg}, accept {accept}",
			mode => $mode, pkg => ref $self, accept => $default_accept[$mode];

	$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() { $_[0]->{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 = use_errno($reason) ? strerror($opts->{errno} || 1) : 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;