misc/translator/VerboseWarnings.pm

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