ErrorHandling.pm 1.8 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104
  1. package Dpkg::ErrorHandling;
  2. use Dpkg;
  3. use Dpkg::Gettext;
  4. use base qw(Exporter);
  5. our @EXPORT = qw(info warning warnerror error errormsg
  6. syserr internerr subprocerr usageerr syntaxerr);
  7. our @EXPORT_OK = qw(report unknown $warnable_error $quiet_warnings);
  8. our $warnable_error = 1;
  9. our $quiet_warnings = 0;
  10. sub report(@)
  11. {
  12. my ($type, $msg) = (shift, shift);
  13. $msg = sprintf($msg, @_) if (@_);
  14. return "$progname: $type: $msg\n";
  15. }
  16. sub info($;@)
  17. {
  18. print report(_g("info"), @_) if (!$quiet_warnings);
  19. }
  20. sub warning($;@)
  21. {
  22. warn report(_g("warning"), @_) if (!$quiet_warnings);
  23. }
  24. sub warnerror(@)
  25. {
  26. if ($warnable_error) {
  27. warning(@_);
  28. } else {
  29. error(@_);
  30. }
  31. }
  32. sub syserr($;@)
  33. {
  34. my $msg = shift;
  35. die report(_g("error"), "$msg: $!", @_);
  36. }
  37. sub error($;@)
  38. {
  39. die report(_g("error"), @_);
  40. }
  41. sub errormsg($;@)
  42. {
  43. print STDERR report(_g("error"), @_);
  44. }
  45. sub internerr($;@)
  46. {
  47. die report(_g("internal error"), @_);
  48. }
  49. sub unknown($)
  50. {
  51. # XXX: implicit argument
  52. my $field = $_;
  53. warning(_g("unknown information field '%s' in input data in %s"),
  54. $field, $_[0]);
  55. }
  56. sub subprocerr(@)
  57. {
  58. my ($p) = (shift);
  59. $p = sprintf($p, @_) if (@_);
  60. require POSIX;
  61. if (POSIX::WIFEXITED($?)) {
  62. error(_g("%s gave error exit status %s"), $p, POSIX::WEXITSTATUS($?));
  63. } elsif (POSIX::WIFSIGNALED($?)) {
  64. error(_g("%s died from signal %s"), $p, POSIX::WTERMSIG($?));
  65. } else {
  66. error(_g("%s failed with unknown exit code %d"), $p, $?);
  67. }
  68. }
  69. sub usageerr(@)
  70. {
  71. my ($msg) = (shift);
  72. $msg = sprintf($msg, @_) if (@_);
  73. warn "$progname: $msg\n\n";
  74. # XXX: access to main namespace
  75. main::usage();
  76. exit(2);
  77. }
  78. sub syntaxerr {
  79. my ($file, $msg) = @_;
  80. error(_g("syntax error in %s at line %d: %s"), $file, $., $msg);
  81. }
  82. 1;