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::Minimal; |
10
|
4
|
|
|
4
|
|
104853
|
use vars '$VERSION'; |
|
4
|
|
|
|
|
21
|
|
|
4
|
|
|
|
|
185
|
|
11
|
|
|
|
|
|
|
$VERSION = '1.06'; |
12
|
|
|
|
|
|
|
|
13
|
4
|
|
|
4
|
|
18
|
use base 'Exporter'; |
|
4
|
|
|
|
|
7
|
|
|
4
|
|
|
|
|
373
|
|
14
|
|
|
|
|
|
|
|
15
|
4
|
|
|
4
|
|
19
|
use warnings; |
|
4
|
|
|
|
|
5
|
|
|
4
|
|
|
|
|
74
|
|
16
|
4
|
|
|
4
|
|
21
|
use strict; |
|
4
|
|
|
|
|
9
|
|
|
4
|
|
|
|
|
88
|
|
17
|
|
|
|
|
|
|
|
18
|
4
|
|
|
4
|
|
1000
|
use Log::Report::Util; |
|
4
|
|
|
|
|
10
|
|
|
4
|
|
|
|
|
525
|
|
19
|
4
|
|
|
4
|
|
31
|
use List::Util qw/first/; |
|
4
|
|
|
|
|
6
|
|
|
4
|
|
|
|
|
307
|
|
20
|
4
|
|
|
4
|
|
21
|
use Scalar::Util qw/blessed/; |
|
4
|
|
|
|
|
5
|
|
|
4
|
|
|
|
|
124
|
|
21
|
|
|
|
|
|
|
|
22
|
4
|
|
|
4
|
|
1310
|
use Log::Report::Minimal::Domain (); |
|
4
|
|
|
|
|
8
|
|
|
4
|
|
|
|
|
4287
|
|
23
|
|
|
|
|
|
|
|
24
|
|
|
|
|
|
|
### if you change anything here, you also have to change Log::Report::Minimal |
25
|
|
|
|
|
|
|
my @make_msg = qw/__ __x __n __nx __xn N__ N__n N__w/; |
26
|
|
|
|
|
|
|
my @functions = qw/report dispatcher try textdomain/; |
27
|
|
|
|
|
|
|
my @reason_functions = qw/trace assert info notice warning |
28
|
|
|
|
|
|
|
mistake error fault alert failure panic/; |
29
|
|
|
|
|
|
|
|
30
|
|
|
|
|
|
|
our @EXPORT_OK = (@make_msg, @functions, @reason_functions); |
31
|
|
|
|
|
|
|
|
32
|
|
|
|
|
|
|
sub trace(@); sub assert(@); sub info(@); sub notice(@); sub warning(@); |
33
|
|
|
|
|
|
|
sub mistake(@); sub error(@); sub fault(@); sub alert(@); sub failure(@); |
34
|
|
|
|
|
|
|
sub panic(@); sub report(@); sub textdomain($@); |
35
|
|
|
|
|
|
|
sub __($); sub __x($@); sub __n($$$@); sub __nx($$$@); sub __xn($$$@); |
36
|
|
|
|
|
|
|
sub N__($); sub N__n($$); sub N__w(@); |
37
|
|
|
|
|
|
|
|
38
|
|
|
|
|
|
|
my ($mode, %need); |
39
|
|
|
|
|
|
|
sub need($) |
40
|
4
|
|
|
4
|
0
|
18
|
{ $mode = shift; |
41
|
4
|
|
|
|
|
12
|
%need = map +($_ => 1), expand_reasons mode_accepts $mode; |
42
|
|
|
|
|
|
|
} |
43
|
|
|
|
|
|
|
need 'NORMAL'; |
44
|
|
|
|
|
|
|
|
45
|
|
|
|
|
|
|
my %textdomains; |
46
|
|
|
|
|
|
|
textdomain 'default'; |
47
|
|
|
|
|
|
|
|
48
|
|
|
|
|
|
|
sub _interpolate(@) |
49
|
3
|
|
|
3
|
|
11
|
{ my ($msgid, %args) = @_; |
50
|
|
|
|
|
|
|
|
51
|
3
|
|
|
|
|
5
|
my $textdomain = $args{_domain}; |
52
|
3
|
50
|
|
|
|
6
|
unless($textdomain) |
53
|
3
|
|
|
|
|
12
|
{ my ($pkg) = caller 1; |
54
|
3
|
|
|
|
|
8
|
$textdomain = pkg2domain $pkg; |
55
|
|
|
|
|
|
|
} |
56
|
|
|
|
|
|
|
|
57
|
3
|
|
|
|
|
5
|
(textdomain $textdomain)->interpolate($msgid, \%args); |
58
|
|
|
|
|
|
|
} |
59
|
|
|
|
|
|
|
|
60
|
|
|
|
|
|
|
# |
61
|
|
|
|
|
|
|
# Some initiations |
62
|
|
|
|
|
|
|
# |
63
|
|
|
|
|
|
|
|
64
|
|
|
|
|
|
|
|
65
|
|
|
|
|
|
|
sub textdomain($@) |
66
|
12
|
50
|
33
|
12
|
1
|
53
|
{ if(@_==1 && blessed $_[0]) |
67
|
0
|
|
|
|
|
0
|
{ my $domain = shift; |
68
|
0
|
|
|
|
|
0
|
return $textdomains{$domain->name} = $domain; |
69
|
|
|
|
|
|
|
} |
70
|
|
|
|
|
|
|
|
71
|
12
|
50
|
|
|
|
35
|
if(@_==2) |
72
|
|
|
|
|
|
|
{ # used for 'maintenance' and testing |
73
|
0
|
0
|
|
|
|
0
|
return delete $textdomains{$_[0]} if $_[1] eq 'DELETE'; |
74
|
0
|
0
|
|
|
|
0
|
return $textdomains{$_[0]} if $_[1] eq 'EXISTS'; |
75
|
|
|
|
|
|
|
} |
76
|
|
|
|
|
|
|
|
77
|
12
|
|
|
|
|
14
|
my $name = shift; |
78
|
12
|
|
66
|
|
|
55
|
my $domain = $textdomains{$name} |
79
|
|
|
|
|
|
|
||= Log::Report::Minimal::Domain->new(name => $name); |
80
|
|
|
|
|
|
|
|
81
|
12
|
50
|
|
|
|
34
|
@_ ? $domain->configure(@_, where => [caller]) : $domain; |
82
|
|
|
|
|
|
|
} |
83
|
|
|
|
|
|
|
|
84
|
|
|
|
|
|
|
|
85
|
|
|
|
|
|
|
# $^S = $EXCEPTIONS_BEING_CAUGHT; parse: undef, eval: 1, else 0 |
86
|
|
|
|
|
|
|
|
87
|
|
|
|
|
|
|
sub _report($$@) |
88
|
2
|
|
|
2
|
|
5
|
{ my ($opts, $reason) = (shift, shift); |
89
|
|
|
|
|
|
|
|
90
|
|
|
|
|
|
|
# return when no-one needs it: skip unused trace() fast! |
91
|
2
|
50
|
|
|
|
9
|
my $stop = exists $opts->{is_fatal} ? $opts->{is_fatal} : is_fatal $reason; |
92
|
2
|
50
|
33
|
|
|
7
|
$need{$reason} || $stop or return; |
93
|
|
|
|
|
|
|
|
94
|
2
|
50
|
|
|
|
6
|
is_reason $reason |
95
|
|
|
|
|
|
|
or error __x"token '{token}' not recognized as reason", token=>$reason; |
96
|
|
|
|
|
|
|
|
97
|
|
|
|
|
|
|
$opts->{errno} ||= $!+0 || $? || 1 |
98
|
2
|
50
|
0
|
|
|
5
|
if use_errno($reason) && !defined $opts->{errno}; |
|
|
|
0
|
|
|
|
|
|
|
|
33
|
|
|
|
|
99
|
|
|
|
|
|
|
|
100
|
2
|
|
|
|
|
4
|
my $message = shift; |
101
|
2
|
50
|
|
|
|
7
|
@_%2 and error __x"odd length parameter list with '{msg}'", msg => $message; |
102
|
|
|
|
|
|
|
|
103
|
2
|
|
|
|
|
6
|
my $show = lc($reason).': '.$message; |
104
|
|
|
|
|
|
|
|
105
|
2
|
100
|
|
|
|
6
|
if($stop) |
106
|
|
|
|
|
|
|
{ # ^S = EXCEPTIONS_BEING_CAUGHT, within eval or try |
107
|
1
|
|
50
|
|
|
7
|
$! = $opts->{errno} || 0; |
108
|
1
|
|
|
|
|
9
|
die "$show\n"; # call the die handler |
109
|
|
|
|
|
|
|
} |
110
|
|
|
|
|
|
|
else |
111
|
1
|
|
|
|
|
9
|
{ warn "$show\n"; # call the warn handler |
112
|
|
|
|
|
|
|
} |
113
|
|
|
|
|
|
|
|
114
|
1
|
|
|
|
|
9
|
1; |
115
|
|
|
|
|
|
|
} |
116
|
|
|
|
|
|
|
|
117
|
|
|
|
|
|
|
|
118
|
0
|
|
|
0
|
1
|
0
|
sub dispatcher($@) { panic "no dispatchers available in ".__PACKAGE__ } |
119
|
|
|
|
|
|
|
|
120
|
|
|
|
|
|
|
|
121
|
|
|
|
|
|
|
sub try(&@) |
122
|
0
|
|
|
0
|
1
|
0
|
{ my $code = shift; |
123
|
|
|
|
|
|
|
|
124
|
0
|
0
|
|
|
|
0
|
@_ % 2 and report {}, PANIC => |
125
|
|
|
|
|
|
|
__x"odd length parameter list for try(): forgot the terminating ';'?"; |
126
|
|
|
|
|
|
|
|
127
|
|
|
|
|
|
|
#XXX MO: only needs the fatal subset, exclude the warns/prints |
128
|
|
|
|
|
|
|
|
129
|
0
|
|
|
|
|
0
|
eval { $code->() }; |
|
0
|
|
|
|
|
0
|
|
130
|
|
|
|
|
|
|
} |
131
|
|
|
|
|
|
|
|
132
|
|
|
|
|
|
|
|
133
|
|
|
|
|
|
|
sub report(@) |
134
|
0
|
0
|
0
|
0
|
1
|
0
|
{ my %opt = @_ && ref $_[0] eq 'HASH' ? %{ (shift) } : (); |
|
0
|
|
|
|
|
0
|
|
135
|
0
|
|
|
|
|
0
|
_report \%opt, @_; |
136
|
|
|
|
|
|
|
} |
137
|
|
|
|
|
|
|
|
138
|
0
|
|
|
0
|
1
|
0
|
sub trace(@) {_report {}, TRACE => @_} |
139
|
0
|
|
|
0
|
1
|
0
|
sub assert(@) {_report {}, ASSERT => @_} |
140
|
0
|
|
|
0
|
1
|
0
|
sub info(@) {_report {}, INFO => @_} |
141
|
0
|
|
|
0
|
1
|
0
|
sub notice(@) {_report {}, NOTICE => @_} |
142
|
1
|
|
|
1
|
1
|
633
|
sub warning(@) {_report {}, WARNING => @_} |
143
|
0
|
|
|
0
|
1
|
0
|
sub mistake(@) {_report {}, MISTAKE => @_} |
144
|
1
|
|
|
1
|
1
|
90
|
sub error(@) {_report {}, ERROR => @_} |
145
|
0
|
|
|
0
|
1
|
0
|
sub fault(@) {_report {}, FAULT => @_} |
146
|
0
|
|
|
0
|
1
|
0
|
sub alert(@) {_report {}, ALERT => @_} |
147
|
0
|
|
|
0
|
1
|
0
|
sub failure(@) {_report {}, FAILURE => @_} |
148
|
0
|
|
|
0
|
1
|
0
|
sub panic(@) {_report {}, PANIC => @_} |
149
|
|
|
|
|
|
|
|
150
|
|
|
|
|
|
|
|
151
|
3
|
|
|
3
|
|
127
|
sub __($) { shift } |
152
|
|
|
|
|
|
|
|
153
|
|
|
|
|
|
|
|
154
|
|
|
|
|
|
|
sub __x($@) |
155
|
1
|
50
|
|
1
|
|
4
|
{ @_%2 or error __x"even length parameter list for __x at {where}" |
156
|
|
|
|
|
|
|
, where => join(' line ', (caller)[1,2]); |
157
|
|
|
|
|
|
|
|
158
|
1
|
|
|
|
|
3
|
_interpolate @_, _expand => 1; |
159
|
|
|
|
|
|
|
} |
160
|
|
|
|
|
|
|
|
161
|
|
|
|
|
|
|
|
162
|
|
|
|
|
|
|
sub __n($$$@) |
163
|
0
|
|
|
0
|
|
0
|
{ my ($single, $plural, $count) = (shift, shift, shift); |
164
|
0
|
0
|
|
|
|
0
|
_interpolate +($count==1 ? $single : $plural) |
165
|
|
|
|
|
|
|
, _count => $count, @_; |
166
|
|
|
|
|
|
|
} |
167
|
|
|
|
|
|
|
|
168
|
|
|
|
|
|
|
|
169
|
|
|
|
|
|
|
sub __nx($$$@) |
170
|
1
|
|
|
1
|
|
468
|
{ my ($single, $plural, $count) = (shift, shift, shift); |
171
|
1
|
50
|
|
|
|
16
|
_interpolate +($count==1 ? $single : $plural) |
172
|
|
|
|
|
|
|
, _count => $count, _expand => 1, @_; |
173
|
|
|
|
|
|
|
} |
174
|
|
|
|
|
|
|
|
175
|
|
|
|
|
|
|
|
176
|
|
|
|
|
|
|
sub __xn($$$@) # repeated for prototype |
177
|
1
|
|
|
1
|
|
886
|
{ my ($single, $plural, $count) = (shift, shift, shift); |
178
|
1
|
50
|
|
|
|
8
|
_interpolate +($count==1 ? $single : $plural) |
179
|
|
|
|
|
|
|
, _count => $count , _expand => 1, @_; |
180
|
|
|
|
|
|
|
} |
181
|
|
|
|
|
|
|
|
182
|
|
|
|
|
|
|
|
183
|
0
|
|
|
0
|
1
|
0
|
sub N__($) { $_[0] } |
184
|
0
|
|
|
0
|
1
|
0
|
sub N__n($$) {@_} |
185
|
1
|
|
|
1
|
1
|
476
|
sub N__w(@) {split " ", $_[0]} |
186
|
|
|
|
|
|
|
|
187
|
|
|
|
|
|
|
#------------------ |
188
|
|
|
|
|
|
|
|
189
|
|
|
|
|
|
|
sub import(@) |
190
|
5
|
|
|
5
|
|
24
|
{ my $class = shift; |
191
|
|
|
|
|
|
|
|
192
|
5
|
100
|
100
|
|
|
27
|
my $to_level = @_ && $_[0] =~ m/^\+\d+$/ ? shift : 0; |
193
|
5
|
100
|
|
|
|
13
|
my $textdomain = @_%2 ? shift : 'default'; |
194
|
5
|
|
|
|
|
7
|
my %opts = @_; |
195
|
5
|
|
50
|
|
|
17
|
my $syntax = delete $opts{syntax} || 'SHORT'; |
196
|
|
|
|
|
|
|
|
197
|
5
|
|
|
|
|
26
|
my ($pkg, $fn, $linenr) = caller $to_level; |
198
|
5
|
|
|
|
|
30
|
pkg2domain $pkg, $textdomain, $fn, $linenr; |
199
|
5
|
|
|
|
|
9
|
my $domain = textdomain $textdomain; |
200
|
|
|
|
|
|
|
|
201
|
|
|
|
|
|
|
need delete $opts{mode} |
202
|
5
|
50
|
|
|
|
13
|
if defined $opts{mode}; |
203
|
|
|
|
|
|
|
|
204
|
5
|
|
|
|
|
5
|
my @export; |
205
|
5
|
50
|
|
|
|
12
|
if(my $in = $opts{import}) |
206
|
0
|
0
|
|
|
|
0
|
{ push @export, ref $in eq 'ARRAY' ? @$in : $in; |
207
|
|
|
|
|
|
|
} |
208
|
|
|
|
|
|
|
else |
209
|
5
|
|
|
|
|
15
|
{ push @export, @functions, @make_msg; |
210
|
|
|
|
|
|
|
|
211
|
5
|
|
50
|
|
|
17
|
my $syntax = delete $opts{syntax} || 'SHORT'; |
212
|
5
|
50
|
0
|
|
|
9
|
if($syntax eq 'SHORT') |
|
|
0
|
|
|
|
|
|
213
|
5
|
|
|
|
|
14
|
{ push @export, @reason_functions |
214
|
|
|
|
|
|
|
} |
215
|
|
|
|
|
|
|
elsif($syntax ne 'REPORT' && $syntax ne 'LONG') |
216
|
0
|
|
|
|
|
0
|
{ error __x"syntax flag must be either SHORT or REPORT, not `{flag}'" |
217
|
|
|
|
|
|
|
, flag => $syntax; |
218
|
|
|
|
|
|
|
} |
219
|
|
|
|
|
|
|
} |
220
|
|
|
|
|
|
|
|
221
|
5
|
|
|
|
|
608
|
$class->export_to_level(1+$to_level, undef, @export); |
222
|
|
|
|
|
|
|
|
223
|
5
|
50
|
|
|
|
2375
|
$domain->configure(%opts, where => [$pkg, $fn, $linenr ]) |
224
|
|
|
|
|
|
|
if %opts; |
225
|
|
|
|
|
|
|
} |
226
|
|
|
|
|
|
|
|
227
|
|
|
|
|
|
|
1; |