File Coverage

File:Dpkg/ErrorHandling.pm
Coverage:55.3%

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
14=encoding utf8
15
16 - 26
=head1 NAME

Dpkg::ErrorHandling - handle error conditions

=head1 DESCRIPTION

This module provides functions to handle all reporting and error handling.

B<Note>: This is a private module, its API can change at any time.

=cut
27
28package Dpkg::ErrorHandling 0.02;
29
30
2013
2013
2013
2013
4858
843
28825
use strict;
31
2013
2013
2013
2013
3269
2342
48767
use warnings;
32
2013
2013
2013
2013
3045
1942
147038
use feature qw(state);
33
34our @EXPORT_OK = qw(
35    REPORT_PROGNAME
36    REPORT_COMMAND
37    REPORT_STATUS
38    REPORT_DEBUG
39    REPORT_INFO
40    REPORT_NOTICE
41    REPORT_WARN
42    REPORT_ERROR
43    report_pretty
44    report_color
45    report
46);
47our @EXPORT = qw(
48    report_options
49    debug
50    info
51    notice
52    warning
53    error
54    errormsg
55    syserr
56    printcmd
57    subprocerr
58    usageerr
59);
60
61
2013
2013
2013
2013
4082
1295
29465
use Exporter qw(import);
62
63
2013
2013
2013
2013
233177
1464
23126
use Dpkg ();
64
2013
2013
2013
2013
224058
2446
215595
use Dpkg::Gettext;
65
66my $quiet_warnings = 0;
67my $debug_level = 0;
68my $info_fh = \*STDOUT;
69
70sub setup_color
71{
72
72
50
72
0
241
    my $mode = $ENV{'DPKG_COLORS'} // 'auto';
73
72
78
    my $use_color;
74
75
72
50
50
207
    if ($mode eq 'auto') {
76        ## no critic (InputOutput::ProhibitInteractiveTest)
77
0
0
0
0
        $use_color = 1 if -t *STDOUT or -t *STDERR;
78    } elsif ($mode eq 'always') {
79
0
0
        $use_color = 1;
80    } else {
81
72
89
        $use_color = 0;
82    }
83
84
72
50
161
    require Term::ANSIColor if $use_color;
85}
86
87use constant {
88
2013
1226650
    REPORT_PROGNAME => 1,
89    REPORT_COMMAND => 2,
90    REPORT_STATUS => 3,
91    REPORT_INFO => 4,
92    REPORT_NOTICE => 5,
93    REPORT_WARN => 6,
94    REPORT_ERROR => 7,
95    REPORT_DEBUG => 8,
96
2013
2013
2013
6779
1989
};
97
98my %report_mode = (
99    REPORT_PROGNAME() => {
100        color => 'bold',
101    },
102    REPORT_COMMAND() => {
103        color => 'bold magenta',
104    },
105    REPORT_STATUS() => {
106        color => 'clear',
107        # We do not translate this name because the untranslated output is
108        # part of the interface.
109        name => 'status',
110    },
111    REPORT_DEBUG() => {
112        color => 'clear',
113        # We do not translate this name because it is a developer interface
114        # and all debug messages are untranslated anyway.
115        name => 'debug',
116    },
117    REPORT_INFO() => {
118        color => 'green',
119        name => g_('info'),
120    },
121    REPORT_NOTICE() => {
122        color => 'yellow',
123        name => g_('notice'),
124    },
125    REPORT_WARN() => {
126        color => 'bold yellow',
127        name => g_('warning'),
128    },
129    REPORT_ERROR() => {
130        color => 'bold red',
131        name => g_('error'),
132    },
133);
134
135sub report_options
136{
137
1770
1770
0
5157
    my (%options) = @_;
138
139
1770
50
4070
    if (exists $options{quiet_warnings}) {
140
1770
2874
        $quiet_warnings = $options{quiet_warnings};
141    }
142
1770
50
4570
    if (exists $options{debug_level}) {
143
0
0
        $debug_level = $options{debug_level};
144    }
145
1770
50
4275
    if (exists $options{info_fh}) {
146
0
0
        $info_fh = $options{info_fh};
147    }
148}
149
150sub report_name
151{
152
252
252
0
213
    my $type = shift;
153
154
252
50
515
    return $report_mode{$type}{name} // '';
155}
156
157sub report_color
158{
159
504
504
0
391
    my $type = shift;
160
161
504
50
1094
    return $report_mode{$type}{color} // 'clear';
162}
163
164sub report_pretty
165{
166
504
504
0
488
    my ($msg, $color) = @_;
167
168
504
450
    state $use_color = setup_color();
169
170
504
50
493
    if ($use_color) {
171
0
0
        return Term::ANSIColor::colored($msg, $color);
172    } else {
173
504
621
        return $msg;
174    }
175}
176
177sub _progname_prefix
178{
179
252
252
524
    return report_pretty("$Dpkg::PROGNAME: ", report_color(REPORT_PROGNAME));
180}
181
182sub _typename_prefix
183{
184
252
252
200
    my $type = shift;
185
186
252
315
    return report_pretty(report_name($type), report_color($type));
187}
188
189sub report(@)
190{
191
252
252
0
395
    my ($type, $msg, @args) = @_;
192
193
252
100
756
    $msg = sprintf $msg, @args if @args;
194
195
252
396
    my $progname = _progname_prefix();
196
252
368
    my $typename = _typename_prefix($type);
197
198
252
2221
    return "$progname$typename: $msg\n";
199}
200
201sub debug
202{
203
0
0
0
0
    my ($level, @args) = @_;
204
205
0
0
0
    print report(REPORT_DEBUG, @args) if $level <= $debug_level;
206}
207
208sub info($;@)
209{
210
0
0
0
0
    my @args = @_;
211
212
0
0
0
0
0
    print { $info_fh } report(REPORT_INFO, @args) if not $quiet_warnings;
213}
214
215sub notice
216{
217
0
0
0
0
    my @args = @_;
218
219
0
0
0
    warn report(REPORT_NOTICE, @args) if not $quiet_warnings;
220}
221
222sub warning($;@)
223{
224
67278
67278
0
181655
    my @args = @_;
225
226
67278
100
136124
    warn report(REPORT_WARN, @args) if not $quiet_warnings;
227}
228
229sub syserr($;@)
230{
231
6
6
0
12
    my ($msg, @args) = @_;
232
233
6
37
    die report(REPORT_ERROR, "$msg: $!", @args);
234}
235
236sub error($;@)
237{
238
186
186
0
314
    my @args = @_;
239
240
186
348
    die report(REPORT_ERROR, @args);
241}
242
243sub errormsg($;@)
244{
245
0
0
0
0
    my @args = @_;
246
247
0
0
0
0
    print { *STDERR } report(REPORT_ERROR, @args);
248}
249
250sub printcmd
251{
252
0
0
0
0
    my (@cmd) = @_;
253
254
0
0
0
0
    print { *STDERR } report_pretty(" @cmd\n", report_color(REPORT_COMMAND));
255}
256
257sub subprocerr(@)
258{
259
3
3
0
5
    my ($p, @args) = @_;
260
261
3
50
10
    $p = sprintf $p, @args if @args;
262
263
3
23
    require POSIX;
264
265
3
50
0
13
    if (POSIX::WIFEXITED($?)) {
266
3
5
        my $ret = POSIX::WEXITSTATUS($?);
267
3
14
        error(g_('%s subprocess returned exit status %d'), $p, $ret);
268    } elsif (POSIX::WIFSIGNALED($?)) {
269
0
        my $sig = POSIX::WTERMSIG($?);
270
0
        error(g_('%s subprocess was killed by signal %d'), $p, $sig);
271    } else {
272
0
        error(g_('%s subprocess failed with unknown status code %d'), $p, $?);
273    }
274}
275
276sub usageerr(@)
277{
278
0
0
0
    my ($msg, @args) = @_;
279
280
0
    state $printforhelp = g_('Use --help for program usage information.');
281
282
0
0
    $msg = sprintf $msg, @args if @args;
283
0
    warn report(REPORT_ERROR, $msg);
284
0
    warn "\n$printforhelp\n";
285
0
    exit(2);
286}
287
288 - 294
=head1 CHANGES

=head2 Version 0.xx

This is a private module.

=cut
295
2961;