ErrorHandling.pm 1.9 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109
  1. package Dpkg::ErrorHandling;
  2. use Dpkg;
  3. use Dpkg::Gettext;
  4. use base qw(Exporter);
  5. our @EXPORT_OK = qw(warning warnerror error errormsg failure unknown
  6. syserr internerr subprocerr usageerr syntaxerr report
  7. info $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 failure($;@)
  33. {
  34. die report(_g("failure"), @_);
  35. }
  36. sub syserr($;@)
  37. {
  38. my $msg = shift;
  39. die report(_g("failure"), "$msg: $!", @_);
  40. }
  41. sub error($;@)
  42. {
  43. die report(_g("error"), @_);
  44. }
  45. sub errormsg($;@)
  46. {
  47. print STDERR report(_g("error"), @_);
  48. }
  49. sub internerr($;@)
  50. {
  51. die report(_g("internal error"), @_);
  52. }
  53. sub unknown($)
  54. {
  55. # XXX: implicit argument
  56. my $field = $_;
  57. warning(_g("unknown information field '%s' in input data in %s"),
  58. $field, $_[0]);
  59. }
  60. sub subprocerr(@)
  61. {
  62. my ($p) = (shift);
  63. $p = sprintf($p, @_) if (@_);
  64. require POSIX;
  65. if (POSIX::WIFEXITED($?)) {
  66. failure(_g("%s gave error exit status %s"), $p, POSIX::WEXITSTATUS($?));
  67. } elsif (POSIX::WIFSIGNALED($?)) {
  68. failure(_g("%s died from signal %s"), $p, POSIX::WTERMSIG($?));
  69. } else {
  70. failure(_g("%s failed with unknown exit code %d"), $p, $?);
  71. }
  72. }
  73. sub usageerr(@)
  74. {
  75. my ($msg) = (shift);
  76. $msg = sprintf($msg, @_) if (@_);
  77. warn "$progname: $msg\n\n";
  78. # XXX: access to main namespace
  79. main::usage();
  80. exit(2);
  81. }
  82. sub syntaxerr {
  83. my ($file, $msg) = @_;
  84. error(_g("syntax error in %s at line %d: %s"), $file, $., $msg);
  85. }
  86. 1;