File Coverage

blib/lib/Log/Report/Util.pm

Criterion	Covered	Total	%
statement	53	74	71.6
branch	29	56	51.7
condition	8	40	20.0
subroutine	13	19	68.4
pod	13	15	86.6
total	116	204	56.8

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

# This software is copyright (c) 2013-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: old style disclaimer to be removed.
#oorestyle: not using Log::Report yet.

# This code is part of distribution Log-Report-Optional. 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::Util;{
our $VERSION = '1.08';
}

use base 'Exporter';

use warnings;
use strict;

use String::Print qw/printi/;

our @EXPORT = qw/
	@reasons is_reason is_fatal use_errno mode_number expand_reasons
	mode_accepts must_show_location must_show_stack escape_chars
	unescape_chars to_html parse_locale pkg2domain
/;
# [0.994 parse_locale deprecated, but kept hidden]

our @EXPORT_OK = qw/%reason_code/;

#use Log::Report 'log-report';
sub N__w($) { split ' ', $_[0] }

# ordered!
our @reasons  = N__w('TRACE ASSERT INFO NOTICE WARNING MISTAKE ERROR FAULT ALERT FAILURE PANIC');
our %reason_code; { my $i=1; %reason_code = map +($_ => $i++), @reasons }

my %reason_set = (
	ALL     => \@reasons,
	FATAL   => [ qw/ERROR FAULT FAILURE PANIC/ ],
	NONE    => [ ],
	PROGRAM => [ qw/TRACE ASSERT INFO NOTICE WARNING PANIC/ ],
	SYSTEM  => [ qw/FAULT ALERT FAILURE/ ],
	USER    => [ qw/MISTAKE ERROR/ ],
);

my %is_fatal  = map +($_ => 1), @{$reason_set{FATAL}};
my %use_errno = map +($_ => 1), qw/FAULT ALERT FAILURE/;

my %modes     = (NORMAL => 0, VERBOSE => 1, ASSERT => 2, DEBUG => 3, 0 => 0, 1 => 1, 2 => 2, 3 => 3);
my @mode_accepts = ('NOTICE-', 'INFO-', 'ASSERT-', 'ALL');

# horrible mutual dependency with Log::Report(::Minimal)
sub error__x($%)
{	if(Log::Report::Minimal->can('error')) # loaded the ::Mimimal version
		 { Log::Report::Minimal::error(Log::Report::Minimal::__x(@_)) }
	else { Log::Report::error(Log::Report::__x(@_)) }
}

#--------------------



sub expand_reasons($)
{	my $reasons = shift or return ();
	$reasons = [ split m/\,/, $reasons ] if ref $reasons ne 'ARRAY';

	my %r;
	foreach my $r (@$reasons)
	{	if($r =~ m/^([a-z]*)\-([a-z]*)/i )
		{	my $begin = $reason_code{$1 || 'TRACE'};
			my $end   = $reason_code{$2 || 'PANIC'};
			$begin && $end
				or error__x "unknown reason {which} in '{reasons}'", which => ($begin ? $2 : $1), reasons => $reasons;

			error__x"reason '{begin}' more serious than '{end}' in '{reasons}", begin => $1, end => $2, reasons => $reasons
				if $begin >= $end;

			$r{$_}++ for $begin..$end;
		}
		elsif($reason_code{$r}) { $r{$reason_code{$r}}++ }
		elsif(my $s = $reason_set{$r}) { $r{$reason_code{$_}}++ for @$s }
		else
		{	error__x"unknown reason {which} in '{reasons}'", which => $r, reasons => $reasons;
		}
	}
	(undef, @reasons)[sort {$a <=> $b} keys %r];
}


sub is_reason($) { $reason_code{$_[0]} }
sub is_fatal($)  { $is_fatal{$_[0]}    }
sub use_errno($) { $use_errno{$_[0]}   }

#--------------------

sub mode_number($)  { $modes{$_[0]} }


sub mode_accepts($) { $mode_accepts[$modes{$_[0]}] }


sub must_show_location($$)
{	my ($mode, $reason) = @_;
	    $reason eq 'ASSERT'
	 || $reason eq 'PANIC'
	 || ($mode==2 && $reason_code{$reason} >= $reason_code{WARNING})
	 || ($mode==3 && $reason_code{$reason} >= $reason_code{MISTAKE});
}


sub must_show_stack($$)
{	my ($mode, $reason) = @_;
	    $reason eq 'PANIC'
	 || ($mode==2 && $reason_code{$reason} >= $reason_code{ALERT})
	 || ($mode==3 && $reason_code{$reason} >= $reason_code{ERROR});
}

#--------------------

my %unescape = (
	'\a' => "\a", '\b' => "\b", '\f' => "\f", '\n' => "\n",
	'\r' => "\r", '\t' => "\t", '\"' => '"', '\\\\' => '\\',
	'\e' =>  "\x1b", '\v' => "\x0b",
);
my %escape   = reverse %unescape;

sub escape_chars($)
{	my $str = shift;
	$str =~ s/([\x00-\x1F\x7F"\\])/$escape{$1} || '?'/ge;
	$str;
}

sub unescape_chars($)
{	my $str = shift;
	$str =~ s/(\\.)/$unescape{$1} || $1/ge;
	$str;
}


my %tohtml = qw/  > gt   < lt   " quot  & amp /;

sub to_html($)
{	my $s = shift;
	$s =~ s/([<>"&])/\&${tohtml{$1}};/g;
	$s;
}


sub parse_locale($)
{	my $locale = shift;
	defined $locale && length $locale
		or return;

	if($locale !~
	m/^ ([a-z_]+)
		(?: \. ([\w-]+) )?  # codeset
		(?: \@ (\S+) )?     # modifier
		$/ix)
	{	# Windows Finnish_Finland.1252?
		$locale =~ s/.*\.//;
		return wantarray ? ($locale) : { language => $locale };
	}

	my ($lang, $codeset, $modifier) = ($1, $2, $3);

	my @subtags  = split /[_-]/, $lang;
	my $primary  = lc shift @subtags;

	my $language
	  = $primary eq 'c'             ? 'C'
	  : $primary eq 'posix'         ? 'POSIX'
	  : $primary =~ m/^[a-z]{2,3}$/ ? $primary            # ISO639-1 and -2
	  : $primary eq 'i' && @subtags ? lc(shift @subtags)  # IANA
	  : $primary eq 'x' && @subtags ? lc(shift @subtags)  # Private
	  : error__x"unknown locale language in locale `{locale}'", locale => $locale;

	my $script;
	$script = ucfirst lc shift @subtags
		if @subtags > 1 && length $subtags[0] > 3;

	my $territory = @subtags ? uc(shift @subtags) : undef;

	return ($language, $territory, $codeset, $modifier)
		if wantarray;

	  +{
		language  => $language,
		script    => $script,
		territory => $territory,
		codeset   => $codeset,
		modifier  => $modifier,
		variant   => join('-', @subtags),
	   };
}


my %pkg2domain;
sub pkg2domain($;$$$)
{	my $pkg = shift;
	my $d   = $pkg2domain{$pkg};
	@_ or return $d ? $d->[0] : 'default';

	my ($domain, $fn, $line) = @_;
	if($d)
	{	# registration already exists
		return $domain if $d->[0] eq $domain;
		printi "conflict: package {pkg} in translation domain {domain1} in {file1} line {line1}, but in {domain2} in {file2} line {line2}",
			pkg => $pkg, domain1 => $domain, file1 => $fn, line1 => $line,
			domain2 => $d->[0], file2 => $d->[1], line2 => $d->[2];
	}

	# new registration
	$pkg2domain{$pkg} = [$domain, $fn, $line];
	$domain;
}

1;