view release on metacpan or  search on metacpan

lib/Log/Report/Util.pm  view on Meta::CPAN

# 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;