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