misc/translator/VerboseWarnings.pm

   1 package VerboseWarnings;
   2
   3 use strict;
   4 #use warnings; FIXME - Bug 2505
   5 require Exporter;
   6
   7 use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS);
   8
   9 ###############################################################################
  10
  11 =head1 NAME
  12
  13 VerboseWarnings.pm - Verbose warnings for Perl scripts
  14
  15 =head1 DESCRIPTION
  16
  17 Contains convenience functions to construct Unix-style informational,
  18 verbose warnings.
  19
  20 =cut
  21
  22 ###############################################################################
  23
  24
  25 @ISA = qw(Exporter);
  26 @EXPORT_OK = qw(
  27     &pedantic_p
  28     &warn_additional
  29     &warn_normal
  30     &warn_pedantic
  31     &error_additional
  32     &error_normal
  33 );
  34 %EXPORT_TAGS = (
  35     'warn' => [ 'warn_additional',  'warn_normal',  'warn_pedantic' ],
  36     'die'  => [ 'error_additional', 'error_normal' ],
  37 );
  38
  39 ###############################################################################
  40
  41 use vars qw( $appName $input $input_abbr $pedantic_p $pedantic_tag $quiet);
  42 use vars qw( $warned $erred );
  43
  44 sub set_application_name ($) {
  45     my($s) = @_;
  46     $appName = $& if !defined $appName && $s =~ /[^\/]+$/;
  47 }
  48
  49 sub application_name () {
  50     return $appName;
  51 }
  52
  53 sub set_input_file_name ($) {
  54     my($s) = @_;
  55     $input = $s;
  56     $input_abbr = $& if defined $s && $s =~ /[^\/]+$/;
  57 }
  58
  59 sub set_pedantic_mode ($) {
  60     my($p) = @_;
  61     $pedantic_p = $p;
  62     $pedantic_tag = $pedantic_p? '': ' (negligible)';
  63 }
  64
  65 sub pedantic_p () {
  66     return $pedantic_p;
  67 }
  68
  69 sub construct_warn_prefix ($$) {
  70     my($prefix, $lc) = @_;
  71     die "construct_warn_prefix called before set_application_name"
  72             unless defined $appName;
  73     die "construct_warn_prefix called before set_input_file_name"
  74             unless defined $input || !defined $lc; # be a bit lenient
  75     die "construct_warn_prefix called before set_pedantic_mode"
  76             unless defined $pedantic_tag;
  77
  78     # FIXME: The line number is not accurate, but should be "close enough"
  79     # FIXME: This wording is worse than what was there, but it's wrong to
  80     # FIXME: hard-code this thing in each warn statement. Need improvement.
  81     return "$appName: $prefix: " . (defined $lc? "$input_abbr: line $lc: ": defined $input_abbr? "$input_abbr: ": '');
  82 }
  83
  84 sub warn_additional ($$) {
  85     my($msg, $lc) = @_;
  86     my $prefix = construct_warn_prefix('Warning', $lc);
  87     $msg .= "\n" unless $msg =~ /\n$/s;
  88     warn "$prefix$msg";
  89 }
  90
  91 sub warn_normal ($$) {
  92     my($msg, $lc) = @_;
  93     $warned += 1;
  94     warn_additional($msg, $lc);
  95 }
  96
  97 sub warn_pedantic ($$$) {
  98     my($msg, $lc, $flag) = @_;
  99     my $prefix = construct_warn_prefix("Warning$pedantic_tag", $lc);
 100     $msg .= "\n" unless $msg =~ /\n$/s;
 101     warn "$prefix$msg" if ($pedantic_p || !$$flag) && $quiet;
 102     if (!$pedantic_p) {
 103         $prefix = construct_warn_prefix("Warning$pedantic_tag", undef);
 104         warn $prefix."Further similar negligible warnings will not be reported, use --pedantic for details\n" unless ($$flag || !$quiet);
 105         $$flag = 1;
 106     }
 107     $warned += 1;
 108 }
 109
 110 sub error_additional ($$) {
 111     my($msg, $lc) = @_;
 112     my $prefix = construct_warn_prefix('ERROR', $lc);
 113     $msg .= "\n" unless $msg =~ /\n$/s;
 114     warn "$prefix$msg";
 115 }
 116
 117 sub error_normal ($$) {
 118     my($msg, $lc) = @_;
 119     $erred += 1;
 120     error_additional($msg, $lc);
 121 }
 122
 123 sub warned () {
 124     return $warned; # number of times warned
 125 }
 126
 127 ###############################################################################