File Coverage

blib/lib/Dpkg/ErrorHandling.pm
Criterion Covered Total %
statement 58 81 71.6
branch 14 34 41.1
condition 4 9 44.4
subroutine 20 25 80.0
pod 0 16 0.0
total 96 165 58.1


line stmt bran cond sub pod time code
1             # This program is free software; you can redistribute it and/or modify
2             # it under the terms of the GNU General Public License as published by
3             # the Free Software Foundation; either version 2 of the License, or
4             # (at your option) any later version.
5             #
6             # This program is distributed in the hope that it will be useful,
7             # but WITHOUT ANY WARRANTY; without even the implied warranty of
8             # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
9             # GNU General Public License for more details.
10             #
11             # You should have received a copy of the GNU General Public License
12             # along with this program. If not, see .
13              
14             package Dpkg::ErrorHandling;
15              
16 563     563   37362359 use strict;
  563         6513  
  563         16373  
17 563     563   2813 use warnings;
  563         1109  
  563         16722  
18 563     563   2863 use feature qw(state);
  563         1124  
  563         112636  
19              
20             our $VERSION = '0.02';
21             our @EXPORT_OK = qw(
22             REPORT_PROGNAME
23             REPORT_COMMAND
24             REPORT_STATUS
25             REPORT_DEBUG
26             REPORT_INFO
27             REPORT_NOTICE
28             REPORT_WARN
29             REPORT_ERROR
30             report_pretty
31             report_color
32             report
33             );
34             our @EXPORT = qw(
35             report_options
36             debug
37             info
38             notice
39             warning
40             error
41             errormsg
42             syserr
43             printcmd
44             subprocerr
45             usageerr
46             );
47              
48 563     563   3950 use Exporter qw(import);
  563         1667  
  563         25924  
49              
50 563     563   235370 use Dpkg ();
  563         1673  
  563         14007  
51 563     563   230102 use Dpkg::Gettext;
  563         1645  
  563         116880  
52              
53             my $quiet_warnings = 0;
54             my $debug_level = 0;
55             my $info_fh = \*STDOUT;
56              
57             sub setup_color
58             {
59 15   50 15 0 182 my $mode = $ENV{'DPKG_COLORS'} // 'auto';
60 15         42 my $use_color;
61              
62 15 50       61 if ($mode eq 'auto') {
    0          
63             ## no critic (InputOutput::ProhibitInteractiveTest)
64 15 50 33     302 $use_color = 1 if -t *STDOUT or -t *STDERR;
65             } elsif ($mode eq 'always') {
66 0         0 $use_color = 1;
67             } else {
68 0         0 $use_color = 0;
69             }
70              
71 15 50       79 require Term::ANSIColor if $use_color;
72             }
73              
74             use constant {
75 563         1241025 REPORT_PROGNAME => 1,
76             REPORT_COMMAND => 2,
77             REPORT_STATUS => 3,
78             REPORT_INFO => 4,
79             REPORT_NOTICE => 5,
80             REPORT_WARN => 6,
81             REPORT_ERROR => 7,
82             REPORT_DEBUG => 8,
83 563     563   5001 };
  563         1126  
84              
85             my %report_mode = (
86             REPORT_PROGNAME() => {
87             color => 'bold',
88             },
89             REPORT_COMMAND() => {
90             color => 'bold magenta',
91             },
92             REPORT_STATUS() => {
93             color => 'clear',
94             # We do not translate this name because the untranslated output is
95             # part of the interface.
96             name => 'status',
97             },
98             REPORT_DEBUG() => {
99             color => 'clear',
100             # We do not translate this name because it is a developer interface
101             # and all debug messages are untranslated anyway.
102             name => 'debug',
103             },
104             REPORT_INFO() => {
105             color => 'green',
106             name => g_('info'),
107             },
108             REPORT_NOTICE() => {
109             color => 'yellow',
110             name => g_('notice'),
111             },
112             REPORT_WARN() => {
113             color => 'bold yellow',
114             name => g_('warning'),
115             },
116             REPORT_ERROR() => {
117             color => 'bold red',
118             name => g_('error'),
119             },
120             );
121              
122             sub report_options
123             {
124 519     519 0 49627 my (%options) = @_;
125              
126 519 50       2599 if (exists $options{quiet_warnings}) {
127 519         1556 $quiet_warnings = $options{quiet_warnings};
128             }
129 519 50       2077 if (exists $options{debug_level}) {
130 0         0 $debug_level = $options{debug_level};
131             }
132 519 50       3116 if (exists $options{info_fh}) {
133 0         0 $info_fh = $options{info_fh};
134             }
135             }
136              
137             sub report_name
138             {
139 62     62 0 103 my $type = shift;
140              
141 62   50     340 return $report_mode{$type}{name} // '';
142             }
143              
144             sub report_color
145             {
146 124     124 0 208 my $type = shift;
147              
148 124   50     511 return $report_mode{$type}{color} // 'clear';
149             }
150              
151             sub report_pretty
152             {
153 124     124 0 238 my ($msg, $color) = @_;
154              
155 124         233 state $use_color = setup_color();
156              
157 124 50       300 if ($use_color) {
158 0         0 return Term::ANSIColor::colored($msg, $color);
159             } else {
160 124         283 return $msg;
161             }
162             }
163              
164             sub _progname_prefix
165             {
166 62     62   231 return report_pretty("$Dpkg::PROGNAME: ", report_color(REPORT_PROGNAME));
167             }
168              
169             sub _typename_prefix
170             {
171 62     62   114 my $type = shift;
172              
173 62         148 return report_pretty(report_name($type), report_color($type));
174             }
175              
176             sub report(@)
177             {
178 62     62 0 172 my ($type, $msg) = (shift, shift);
179              
180 62 100       429 $msg = sprintf($msg, @_) if (@_);
181              
182 62         305 my $progname = _progname_prefix();
183 62         255 my $typename = _typename_prefix($type);
184              
185 62         813 return "$progname$typename: $msg\n";
186             }
187              
188             sub debug
189             {
190 0     0 0 0 my $level = shift;
191 0 0       0 print report(REPORT_DEBUG, @_) if $level <= $debug_level;
192             }
193              
194             sub info($;@)
195             {
196 0 0   0 0 0 print { $info_fh } report(REPORT_INFO, @_) if not $quiet_warnings;
  0         0  
197             }
198              
199             sub notice
200             {
201 1 50   1 0 17 warn report(REPORT_NOTICE, @_) if not $quiet_warnings;
202             }
203              
204             sub warning($;@)
205             {
206 22420 100   22420 0 131475 warn report(REPORT_WARN, @_) if not $quiet_warnings;
207             }
208              
209             sub syserr($;@)
210             {
211 1     1 0 3 my $msg = shift;
212 1         16 die report(REPORT_ERROR, "$msg: $!", @_);
213             }
214              
215             sub error($;@)
216             {
217 47     47 0 262 die report(REPORT_ERROR, @_);
218             }
219              
220             sub errormsg($;@)
221             {
222 0     0 0 0 print { *STDERR } report(REPORT_ERROR, @_);
  0         0  
223             }
224              
225             sub printcmd
226             {
227 0     0 0 0 my (@cmd) = @_;
228              
229 0         0 print { *STDERR } report_pretty(" @cmd\n", report_color(REPORT_COMMAND));
  0         0  
230             }
231              
232             sub subprocerr(@)
233             {
234 1     1 0 13 my ($p) = (shift);
235              
236 1 50       11 $p = sprintf($p, @_) if (@_);
237              
238 1         43 require POSIX;
239              
240 1 50       24 if (POSIX::WIFEXITED($?)) {
    0          
241 1         15 my $ret = POSIX::WEXITSTATUS($?);
242 1         23 error(g_('%s subprocess returned exit status %d'), $p, $ret);
243             } elsif (POSIX::WIFSIGNALED($?)) {
244 0           my $sig = POSIX::WTERMSIG($?);
245 0           error(g_('%s subprocess was killed by signal %d'), $p, $sig);
246             } else {
247 0           error(g_('%s subprocess failed with unknown status code %d'), $p, $?);
248             }
249             }
250              
251             sub usageerr(@)
252             {
253 0     0 0   my ($msg) = (shift);
254              
255 0           state $printforhelp = g_('Use --help for program usage information.');
256              
257 0 0         $msg = sprintf($msg, @_) if (@_);
258 0           warn report(REPORT_ERROR, $msg);
259 0           warn "\n$printforhelp\n";
260 0           exit(2);
261             }
262              
263             1;