File Coverage

blib/lib/Log/Report/Util.pm
Criterion Covered Total %
statement 58 79 73.4
branch 31 58 53.4
condition 8 40 20.0
subroutine 14 20 70.0
pod 13 15 86.6
total 124 212 58.4


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