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