scripts/Dpkg/ErrorHandling.pm

   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 =head1 NAME
  17
  18 Dpkg::ErrorHandling - handle error conditions
  19
  20 =head1 DESCRIPTION
  21
  22 This module provides functions to handle all reporting and error handling.
  23
  24 B<Note>: This is a private module, its API can change at any time.
  25
  26 =cut
  27
  28 package Dpkg::ErrorHandling 0.02;
  29
  30 use strict;
  31 use warnings;
  32 use feature qw(state);
  33
  34 our @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 );
  47 our @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 use Exporter qw(import);
  62
  63 use Dpkg ();
  64 use Dpkg::Gettext;
  65
  66 my $quiet_warnings = 0;
  67 my $debug_level = 0;
  68 my $info_fh = \*STDOUT;
  69
  70 sub setup_color
  71 {
  72     my $mode = $ENV{'DPKG_COLORS'} // 'auto';
  73     my $use_color;
  74
  75     if ($mode eq 'auto') {
  76         ## no critic (InputOutput::ProhibitInteractiveTest)
  77         $use_color = 1 if -t *STDOUT or -t *STDERR;
  78     } elsif ($mode eq 'always') {
  79         $use_color = 1;
  80     } else {
  81         $use_color = 0;
  82     }
  83
  84     require Term::ANSIColor if $use_color;
  85 }
  86
  87 use constant {
  88     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 };
  97
  98 my %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
 135 sub report_options
 136 {
 137     my (%options) = @_;
 138
 139     if (exists $options{quiet_warnings}) {
 140         $quiet_warnings = $options{quiet_warnings};
 141     }
 142     if (exists $options{debug_level}) {
 143         $debug_level = $options{debug_level};
 144     }
 145     if (exists $options{info_fh}) {
 146         $info_fh = $options{info_fh};
 147     }
 148 }
 149
 150 sub report_name
 151 {
 152     my $type = shift;
 153
 154     return $report_mode{$type}{name} // '';
 155 }
 156
 157 sub report_color
 158 {
 159     my $type = shift;
 160
 161     return $report_mode{$type}{color} // 'clear';
 162 }
 163
 164 sub report_pretty
 165 {
 166     my ($msg, $color) = @_;
 167
 168     state $use_color = setup_color();
 169
 170     if ($use_color) {
 171         return Term::ANSIColor::colored($msg, $color);
 172     } else {
 173         return $msg;
 174     }
 175 }
 176
 177 sub _progname_prefix
 178 {
 179     return report_pretty("$Dpkg::PROGNAME: ", report_color(REPORT_PROGNAME));
 180 }
 181
 182 sub _typename_prefix
 183 {
 184     my $type = shift;
 185
 186     return report_pretty(report_name($type), report_color($type));
 187 }
 188
 189 sub report(@)
 190 {
 191     my ($type, $msg, @args) = @_;
 192
 193     $msg = sprintf $msg, @args if @args;
 194
 195     my $progname = _progname_prefix();
 196     my $typename = _typename_prefix($type);
 197
 198     return "$progname$typename: $msg\n";
 199 }
 200
 201 sub debug
 202 {
 203     my ($level, @args) = @_;
 204
 205     print report(REPORT_DEBUG, @args) if $level <= $debug_level;
 206 }
 207
 208 sub info($;@)
 209 {
 210     my @args = @_;
 211
 212     print { $info_fh } report(REPORT_INFO, @args) if not $quiet_warnings;
 213 }
 214
 215 sub notice
 216 {
 217     my @args = @_;
 218
 219     warn report(REPORT_NOTICE, @args) if not $quiet_warnings;
 220 }
 221
 222 sub warning($;@)
 223 {
 224     my @args = @_;
 225
 226     warn report(REPORT_WARN, @args) if not $quiet_warnings;
 227 }
 228
 229 sub syserr($;@)
 230 {
 231     my ($msg, @args) = @_;
 232
 233     die report(REPORT_ERROR, "$msg: $!", @args);
 234 }
 235
 236 sub error($;@)
 237 {
 238     my @args = @_;
 239
 240     die report(REPORT_ERROR, @args);
 241 }
 242
 243 sub errormsg($;@)
 244 {
 245     my @args = @_;
 246
 247     print { *STDERR } report(REPORT_ERROR, @args);
 248 }
 249
 250 sub printcmd
 251 {
 252     my (@cmd) = @_;
 253
 254     print { *STDERR } report_pretty(" @cmd\n", report_color(REPORT_COMMAND));
 255 }
 256
 257 sub subprocerr(@)
 258 {
 259     my ($p, @args) = @_;
 260
 261     $p = sprintf $p, @args if @args;
 262
 263     require POSIX;
 264
 265     if (POSIX::WIFEXITED($?)) {
 266         my $ret = POSIX::WEXITSTATUS($?);
 267         error(g_('%s subprocess returned exit status %d'), $p, $ret);
 268     } elsif (POSIX::WIFSIGNALED($?)) {
 269         my $sig = POSIX::WTERMSIG($?);
 270         error(g_('%s subprocess was killed by signal %d'), $p, $sig);
 271     } else {
 272         error(g_('%s subprocess failed with unknown status code %d'), $p, $?);
 273     }
 274 }
 275
 276 sub usageerr(@)
 277 {
 278     my ($msg, @args) = @_;
 279
 280     state $printforhelp = g_('Use --help for program usage information.');
 281
 282     $msg = sprintf $msg, @args if @args;
 283     warn report(REPORT_ERROR, $msg);
 284     warn "\n$printforhelp\n";
 285     exit(2);
 286 }
 287
 288 =head1 CHANGES
 289
 290 =head2 Version 0.xx
 291
 292 This is a private module.
 293
 294 =cut
 295
 296 1;