misc/translator/VerboseWarnings.pm

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