1# Copyrights 2013-2021 by [Mark Overmeer <mark@overmeer.net>]. 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-Optional. Meta-POD processed 6# with 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::Util; 10use vars '$VERSION'; 11$VERSION = '1.07'; 12 13use base 'Exporter'; 14 15use warnings; 16use strict; 17 18use String::Print qw(printi); 19 20our @EXPORT = qw/ 21 @reasons is_reason is_fatal use_errno 22 mode_number expand_reasons mode_accepts 23 must_show_location must_show_stack 24 escape_chars unescape_chars to_html 25 parse_locale 26 pkg2domain 27 /; 28# [0.994 parse_locale deprecated, but kept hidden] 29 30our @EXPORT_OK = qw/%reason_code/; 31 32#use Log::Report 'log-report'; 33sub N__w($) { split ' ', $_[0] } 34 35# ordered! 36our @reasons = N__w('TRACE ASSERT INFO NOTICE WARNING 37 MISTAKE ERROR FAULT ALERT FAILURE PANIC'); 38our %reason_code; { my $i=1; %reason_code = map +($_ => $i++), @reasons } 39 40my %reason_set = ( 41 ALL => \@reasons, 42 FATAL => [ qw/ERROR FAULT FAILURE PANIC/ ], 43 NONE => [ ], 44 PROGRAM => [ qw/TRACE ASSERT INFO NOTICE WARNING PANIC/ ], 45 SYSTEM => [ qw/FAULT ALERT FAILURE/ ], 46 USER => [ qw/MISTAKE ERROR/ ], 47); 48 49my %is_fatal = map +($_ => 1), @{$reason_set{FATAL}}; 50my %use_errno = map +($_ => 1), qw/FAULT ALERT FAILURE/; 51 52my %modes = (NORMAL => 0, VERBOSE => 1, ASSERT => 2, DEBUG => 3 53 , 0 => 0, 1 => 1, 2 => 2, 3 => 3); 54my @mode_accepts = ('NOTICE-', 'INFO-', 'ASSERT-', 'ALL'); 55 56# horrible mutual dependency with Log::Report(::Minimal) 57sub error__x($%) 58{ if(Log::Report::Minimal->can('error')) # loaded the ::Mimimal version 59 { Log::Report::Minimal::error(Log::Report::Minimal::__x(@_)) } 60 else { Log::Report::error(Log::Report::__x(@_)) } 61} 62 63 64 65sub expand_reasons($) 66{ my $reasons = shift or return (); 67 $reasons = [ split m/\,/, $reasons ] if ref $reasons ne 'ARRAY'; 68 69 my %r; 70 foreach my $r (@$reasons) 71 { if($r =~ m/^([a-z]*)\-([a-z]*)/i ) 72 { my $begin = $reason_code{$1 || 'TRACE'}; 73 my $end = $reason_code{$2 || 'PANIC'}; 74 $begin && $end 75 or error__x "unknown reason {which} in '{reasons}'" 76 , which => ($begin ? $2 : $1), reasons => $reasons; 77 78 error__x"reason '{begin}' more serious than '{end}' in '{reasons}" 79 , begin => $1, end => $2, reasons => $reasons 80 if $begin >= $end; 81 82 $r{$_}++ for $begin..$end; 83 } 84 elsif($reason_code{$r}) { $r{$reason_code{$r}}++ } 85 elsif(my $s = $reason_set{$r}) { $r{$reason_code{$_}}++ for @$s } 86 else 87 { error__x"unknown reason {which} in '{reasons}'" 88 , which => $r, reasons => $reasons; 89 } 90 } 91 (undef, @reasons)[sort {$a <=> $b} keys %r]; 92} 93 94 95sub is_reason($) { $reason_code{$_[0]} } 96sub is_fatal($) { $is_fatal{$_[0]} } 97sub use_errno($) { $use_errno{$_[0]} } 98 99#-------------------------- 100 101sub mode_number($) { $modes{$_[0]} } 102 103 104sub mode_accepts($) { $mode_accepts[$modes{$_[0]}] } 105 106 107sub must_show_location($$) 108{ my ($mode, $reason) = @_; 109 $reason eq 'ASSERT' 110 || $reason eq 'PANIC' 111 || ($mode==2 && $reason_code{$reason} >= $reason_code{WARNING}) 112 || ($mode==3 && $reason_code{$reason} >= $reason_code{MISTAKE}); 113} 114 115 116sub must_show_stack($$) 117{ my ($mode, $reason) = @_; 118 $reason eq 'PANIC' 119 || ($mode==2 && $reason_code{$reason} >= $reason_code{ALERT}) 120 || ($mode==3 && $reason_code{$reason} >= $reason_code{ERROR}); 121} 122 123#------------------------- 124 125my %unescape = 126 ( '\a' => "\a", '\b' => "\b", '\f' => "\f", '\n' => "\n" 127 , '\r' => "\r", '\t' => "\t", '\"' => '"', '\\\\' => '\\' 128 , '\e' => "\x1b", '\v' => "\x0b" 129 ); 130my %escape = reverse %unescape; 131 132sub escape_chars($) 133{ my $str = shift; 134 $str =~ s/([\x00-\x1F\x7F"\\])/$escape{$1} || '?'/ge; 135 $str; 136} 137 138sub unescape_chars($) 139{ my $str = shift; 140 $str =~ s/(\\.)/$unescape{$1} || $1/ge; 141 $str; 142} 143 144 145my %tohtml = qw/ > gt < lt " quot & amp /; 146 147sub to_html($) 148{ my $s = shift; 149 $s =~ s/([<>"&])/\&${tohtml{$1}};/g; 150 $s; 151} 152 153 154sub parse_locale($) 155{ my $locale = shift; 156 defined $locale && length $locale 157 or return; 158 159 if($locale !~ 160 m/^ ([a-z_]+) 161 (?: \. ([\w-]+) )? # codeset 162 (?: \@ (\S+) )? # modifier 163 $/ix) 164 { # Windows Finnish_Finland.1252? 165 $locale =~ s/.*\.//; 166 return wantarray ? ($locale) : { language => $locale }; 167 } 168 169 my ($lang, $codeset, $modifier) = ($1, $2, $3); 170 171 my @subtags = split /[_-]/, $lang; 172 my $primary = lc shift @subtags; 173 174 my $language 175 = $primary eq 'c' ? 'C' 176 : $primary eq 'posix' ? 'POSIX' 177 : $primary =~ m/^[a-z]{2,3}$/ ? $primary # ISO639-1 and -2 178 : $primary eq 'i' && @subtags ? lc(shift @subtags) # IANA 179 : $primary eq 'x' && @subtags ? lc(shift @subtags) # Private 180 : error__x"unknown locale language in locale `{locale}'" 181 , locale => $locale; 182 183 my $script; 184 $script = ucfirst lc shift @subtags 185 if @subtags > 1 && length $subtags[0] > 3; 186 187 my $territory = @subtags ? uc(shift @subtags) : undef; 188 189 return ($language, $territory, $codeset, $modifier) 190 if wantarray; 191 192 +{ language => $language 193 , script => $script 194 , territory => $territory 195 , codeset => $codeset 196 , modifier => $modifier 197 , variant => join('-', @subtags) 198 }; 199} 200 201 202my %pkg2domain; 203sub pkg2domain($;$$$) 204{ my $pkg = shift; 205 my $d = $pkg2domain{$pkg}; 206 @_ or return $d ? $d->[0] : 'default'; 207 208 my ($domain, $fn, $line) = @_; 209 if($d) 210 { # registration already exists 211 return $domain if $d->[0] eq $domain; 212 printi "conflict: package {pkg} in {domain1} in {file1} line {line1}, but in {domain2} in {file2} line {line2}" 213 , pkg => $pkg 214 , domain1 => $domain, file1 => $fn, line1 => $line 215 , domain2 => $d->[0], file2 => $d->[1], line2 => $d->[2]; 216 } 217 218 # new registration 219 $pkg2domain{$pkg} = [$domain, $fn, $line]; 220 $domain; 221} 222 2231; 224