chiark - git - mdw - dpkg/blob - 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 package Dpkg::ErrorHandling;
  15
  16 use strict;
  17 use warnings;
  18
  19 our $VERSION = '0.02';
  20 our @EXPORT_OK = qw(
  21     REPORT_PROGNAME
  22     REPORT_COMMAND
  23     REPORT_STATUS
  24     REPORT_DEBUG
  25     REPORT_INFO
  26     REPORT_NOTICE
  27     REPORT_WARN
  28     REPORT_ERROR
  29     report_pretty
  30     report_color
  31     report
  32 );
  33 our @EXPORT = qw(
  34     report_options
  35     debug
  36     info
  37     notice
  38     warning
  39     error
  40     errormsg
  41     syserr
  42     printcmd
  43     subprocerr
  44     usageerr
  45 );
  46
  47 use Exporter qw(import);
  48 use Term::ANSIColor;
  49
  50 use Dpkg ();
  51 use Dpkg::Gettext;
  52
  53 my $quiet_warnings = 0;
  54 my $debug_level = 0;
  55 my $info_fh = \*STDOUT;
  56 my $use_color = 0;
  57
  58 sub setup_color
  59 {
  60     my $mode = $ENV{'DPKG_COLORS'} // 'auto';
  61
  62     if ($mode eq 'auto') {
  63         ## no critic (InputOutput::ProhibitInteractiveTest)
  64         $use_color = 1 if -t *STDOUT or -t *STDERR;
  65     } elsif ($mode eq 'always') {
  66         $use_color = 1;
  67     } else {
  68         $use_color = 0;
  69     }
  70 }
  71
  72 setup_color();
  73
  74 use constant {
  75     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 };
  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     my (%options) = @_;
 125
 126     if (exists $options{quiet_warnings}) {
 127         $quiet_warnings = $options{quiet_warnings};
 128     }
 129     if (exists $options{debug_level}) {
 130         $debug_level = $options{debug_level};
 131     }
 132     if (exists $options{info_fh}) {
 133         $info_fh = $options{info_fh};
 134     }
 135 }
 136
 137 sub report_name
 138 {
 139     my $type = shift;
 140
 141     return $report_mode{$type}{name} // '';
 142 }
 143
 144 sub report_color
 145 {
 146     my $type = shift;
 147
 148     return $report_mode{$type}{color} // 'clear';
 149 }
 150
 151 sub report_pretty
 152 {
 153     my ($msg, $color) = @_;
 154
 155     if ($use_color) {
 156         return colored($msg, $color);
 157     } else {
 158         return $msg;
 159     }
 160 }
 161
 162 sub _progname_prefix
 163 {
 164     return report_pretty("$Dpkg::PROGNAME: ", report_color(REPORT_PROGNAME));
 165 }
 166
 167 sub _typename_prefix
 168 {
 169     my $type = shift;
 170
 171     return report_pretty(report_name($type), report_color($type));
 172 }
 173
 174 sub report(@)
 175 {
 176     my ($type, $msg) = (shift, shift);
 177
 178     $msg = sprintf($msg, @_) if (@_);
 179
 180     my $progname = _progname_prefix();
 181     my $typename = _typename_prefix($type);
 182
 183     return "$progname$typename: $msg\n";
 184 }
 185
 186 sub debug
 187 {
 188     my $level = shift;
 189     print report(REPORT_DEBUG, @_) if $level <= $debug_level;
 190 }
 191
 192 sub info($;@)
 193 {
 194     print { $info_fh } report(REPORT_INFO, @_) if not $quiet_warnings;
 195 }
 196
 197 sub notice
 198 {
 199     warn report(REPORT_NOTICE, @_) if not $quiet_warnings;
 200 }
 201
 202 sub warning($;@)
 203 {
 204     warn report(REPORT_WARN, @_) if not $quiet_warnings;
 205 }
 206
 207 sub syserr($;@)
 208 {
 209     my $msg = shift;
 210     die report(REPORT_ERROR, "$msg: $!", @_);
 211 }
 212
 213 sub error($;@)
 214 {
 215     die report(REPORT_ERROR, @_);
 216 }
 217
 218 sub errormsg($;@)
 219 {
 220     print { *STDERR } report(REPORT_ERROR, @_);
 221 }
 222
 223 sub printcmd
 224 {
 225     my (@cmd) = @_;
 226
 227     print { *STDERR } report_pretty(" @cmd\n", report_color(REPORT_COMMAND));
 228 }
 229
 230 sub subprocerr(@)
 231 {
 232     my ($p) = (shift);
 233
 234     $p = sprintf($p, @_) if (@_);
 235
 236     require POSIX;
 237
 238     if (POSIX::WIFEXITED($?)) {
 239         error(g_('%s gave error exit status %s'), $p, POSIX::WEXITSTATUS($?));
 240     } elsif (POSIX::WIFSIGNALED($?)) {
 241         error(g_('%s died from signal %s'), $p, POSIX::WTERMSIG($?));
 242     } else {
 243         error(g_('%s failed with unknown exit code %d'), $p, $?);
 244     }
 245 }
 246
 247 my $printforhelp = g_('Use --help for program usage information.');
 248
 249 sub usageerr(@)
 250 {
 251     my ($msg) = (shift);
 252
 253     $msg = sprintf($msg, @_) if (@_);
 254     warn report(REPORT_ERROR, $msg);
 255     warn "\n$printforhelp\n";
 256     exit(2);
 257 }
 258
 259 1;