File Coverage

File:Dpkg/ErrorHandling.pm
Coverage:55.8%

linestmtbrancondsubpodtimecode
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 <https://www.gnu.org/licenses/>.
13
14package Dpkg::ErrorHandling;
15
16
640
640
640
640
1278
1146
7065
use strict;
17
640
640
640
640
1198
38
11006
use warnings;
18
640
640
640
640
1257
600
46974
use feature qw(state);
19
20our $VERSION = '0.02';
21our @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);
34our @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
640
640
640
640
1798
648
6938
use Exporter qw(import);
49
50
640
640
640
640
68098
620
6544
use Dpkg ();
51
640
640
640
640
70699
624
68836
use Dpkg::Gettext;
52
53my $quiet_warnings = 0;
54my $debug_level = 0;
55my $info_fh = \*STDOUT;
56
57sub setup_color
58{
59
18
50
18
0
73
    my $mode = $ENV{'DPKG_COLORS'} // 'auto';
60
18
21
    my $use_color;
61
62
18
50
50
63
    if ($mode eq 'auto') {
63        ## no critic (InputOutput::ProhibitInteractiveTest)
64
0
0
0
0
        $use_color = 1 if -t *STDOUT or -t *STDERR;
65    } elsif ($mode eq 'always') {
66
0
0
        $use_color = 1;
67    } else {
68
18
24
        $use_color = 0;
69    }
70
71
18
50
39
    require Term::ANSIColor if $use_color;
72}
73
74use constant {
75
640
378327
    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
640
640
640
2409
582
};
84
85my %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
122sub report_options
123{
124
562
562
0
1120
    my (%options) = @_;
125
126
562
50
1698
    if (exists $options{quiet_warnings}) {
127
562
1079
        $quiet_warnings = $options{quiet_warnings};
128    }
129
562
50
1124
    if (exists $options{debug_level}) {
130
0
0
        $debug_level = $options{debug_level};
131    }
132
562
50
1079
    if (exists $options{info_fh}) {
133
0
0
        $info_fh = $options{info_fh};
134    }
135}
136
137sub report_name
138{
139
68
68
0
52
    my $type = shift;
140
141
68
50
119
    return $report_mode{$type}{name} // '';
142}
143
144sub report_color
145{
146
136
136
0
119
    my $type = shift;
147
148
136
50
269
    return $report_mode{$type}{color} // 'clear';
149}
150
151sub report_pretty
152{
153
136
136
0
128
    my ($msg, $color) = @_;
154
155
136
154
    state $use_color = setup_color();
156
157
136
50
130
    if ($use_color) {
158
0
0
        return Term::ANSIColor::colored($msg, $color);
159    } else {
160
136
154
        return $msg;
161    }
162}
163
164sub _progname_prefix
165{
166
68
68
113
    return report_pretty("$Dpkg::PROGNAME: ", report_color(REPORT_PROGNAME));
167}
168
169sub _typename_prefix
170{
171
68
68
51
    my $type = shift;
172
173
68
84
    return report_pretty(report_name($type), report_color($type));
174}
175
176sub report(@)
177{
178
68
68
0
83
    my ($type, $msg) = (shift, shift);
179
180
68
100
193
    $msg = sprintf($msg, @_) if (@_);
181
182
68
87
    my $progname = _progname_prefix();
183
68
79
    my $typename = _typename_prefix($type);
184
185
68
535
    return "$progname$typename: $msg\n";
186}
187
188sub debug
189{
190
0
0
0
0
    my $level = shift;
191
0
0
0
    print report(REPORT_DEBUG, @_) if $level <= $debug_level;
192}
193
194sub info($;@)
195{
196
0
0
0
0
0
0
0
    print { $info_fh } report(REPORT_INFO, @_) if not $quiet_warnings;
197}
198
199sub notice
200{
201
0
0
0
0
0
    warn report(REPORT_NOTICE, @_) if not $quiet_warnings;
202}
203
204sub warning($;@)
205{
206
22425
100
22425
0
35173
    warn report(REPORT_WARN, @_) if not $quiet_warnings;
207}
208
209sub syserr($;@)
210{
211
2
2
0
1
    my $msg = shift;
212
2
6
    die report(REPORT_ERROR, "$msg: $!", @_);
213}
214
215sub error($;@)
216{
217
47
47
0
96
    die report(REPORT_ERROR, @_);
218}
219
220sub errormsg($;@)
221{
222
0
0
0
0
0
0
    print { *STDERR } report(REPORT_ERROR, @_);
223}
224
225sub printcmd
226{
227
0
0
0
0
    my (@cmd) = @_;
228
229
0
0
0
0
    print { *STDERR } report_pretty(" @cmd\n", report_color(REPORT_COMMAND));
230}
231
232sub subprocerr(@)
233{
234
1
1
0
3
    my ($p) = (shift);
235
236
1
50
3
    $p = sprintf($p, @_) if (@_);
237
238
1
13
    require POSIX;
239
240
1
50
0
6
    if (POSIX::WIFEXITED($?)) {
241
1
1
        my $ret = POSIX::WEXITSTATUS($?);
242
1
5
        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
251sub 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
2631;