misc/translator/VerboseWarnings.pm

   1 package VerboseWarnings;
   2
   3 use strict;
   4 require Exporter;
   5
   6 use vars qw($VERSION @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 $VERSION = 0.01;
  24
  25 @ISA = qw(Exporter);
  26 @EXPORT_OK = qw(
  27     &pedantic_p
  28     &warn_normal
  29     &warn_pedantic
  30     &error_normal
  31 );
  32
  33 ###############################################################################
  34
  35 use vars qw( $appName $input $input_abbr $pedantic_p $pedantic_tag );
  36
  37 sub set_application_name ($) {
  38     my($s) = @_;
  39     $appName = $& if !defined $appName && $s =~ /[^\/]+$/;
  40 }
  41
  42 sub set_input_file_name ($) {
  43     my($s) = @_;
  44     $input = $s;
  45     $input_abbr = $& if defined $s && $s =~ /[^\/]+$/;
  46 }
  47
  48 sub set_pedantic_mode ($) {
  49     my($p) = @_;
  50     $pedantic_p = $p;
  51     $pedantic_tag = $pedantic_p? '': ' (negligible)';
  52 }
  53
  54 sub pedantic_p () {
  55     return $pedantic_p;
  56 }
  57
  58 sub construct_warn_prefix ($$) {
  59     my($prefix, $lc) = @_;
  60     die "construct_warn_prefix called before set_application_name"
  61             unless defined $appName;
  62     die "construct_warn_prefix called before set_input_file_name"
  63             unless defined $input;
  64     die "construct_warn_prefix called before set_pedantic_mode"
  65             unless defined $pedantic_tag;
  66
  67     # FIXME: The line number is not accurate, but should be "close enough"
  68     # FIXME: This wording is worse than what was there, but it's wrong to
  69     # FIXME: hard-code this thing in each warn statement. Need improvement.
  70     return "$appName: $prefix: " . (defined $lc? "$input_abbr: line $lc: ": "$input_abbr: ");
  71 }
  72
  73 sub warn_normal ($$) {
  74     my($msg, $lc) = @_;
  75     my $prefix = construct_warn_prefix('Warning', $lc);
  76     $msg .= "\n" unless $msg =~ /\n$/s;
  77     warn "$prefix$msg";
  78 }
  79
  80 sub warn_pedantic ($$$) {
  81     my($msg, $lc, $flag) = @_;
  82     my $prefix = construct_warn_prefix("Warning$pedantic_tag", $lc);
  83     $msg .= "\n" unless $msg =~ /\n$/s;
  84     warn "$prefix$msg" if $pedantic_p || !$$flag;
  85     if (!$pedantic_p) {
  86         $prefix = construct_warn_prefix("Warning$pedantic_tag", undef);
  87         warn $prefix."Further similar negligible warnings will not be reported, use --pedantic for details\n" unless $$flag;
  88         $$flag = 1;
  89     }
  90 }
  91
  92 sub error_normal ($$) {
  93     my($msg, $lc) = @_;
  94     my $prefix = construct_warn_prefix('ERROR', $lc);
  95     $msg .= "\n" unless $msg =~ /\n$/s;
  96     warn "$prefix$msg";
  97 }
  98
  99 ###############################################################################