File Coverage

blib/lib/Log/Report/Minimal.pm
Criterion Covered Total %
statement 77 104 74.0
branch 22 52 42.3
condition 11 32 34.3
subroutine 20 35 57.1
pod 18 19 94.7
total 148 242 61.1


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;