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