package VerboseWarnings;

use Modern::Perl;

###############################################################################

=head1 NAME

VerboseWarnings.pm - Verbose warnings for Perl scripts

=head1 DESCRIPTION

Contains convenience functions to construct Unix-style informational,
verbose warnings.

=cut

###############################################################################

our (@ISA, @EXPORT_OK);
BEGIN {
    require Exporter;
    @ISA = qw(Exporter);
    @EXPORT_OK = qw(
        pedantic_p
        warn_additional
        warn_normal
        warn_pedantic
        error_additional
        error_normal
    );
}

###############################################################################

use vars qw( $appName $input $input_abbr $pedantic_p $pedantic_tag $quiet);
use vars qw( $warned $erred );

sub set_application_name {
    my($s) = @_;
    $appName = $& if !defined $appName && $s =~ /[^\/]+$/;
}

sub application_name {
    return $appName;
}

sub set_input_file_name {
    my($s) = @_;
    $input = $s;
    $input_abbr = $& if defined $s && $s =~ /[^\/]+$/;
}

sub set_pedantic_mode {
    my($p) = @_;
    $pedantic_p = $p;
    $pedantic_tag = $pedantic_p? '': ' (negligible)';
}

sub pedantic_p {
    return $pedantic_p;
}

sub construct_warn_prefix {
    my($prefix, $lc) = @_;
    die "construct_warn_prefix called before set_application_name"
	    unless defined $appName;
    die "construct_warn_prefix called before set_input_file_name"
	    unless defined $input || !defined $lc; # be a bit lenient
    die "construct_warn_prefix called before set_pedantic_mode"
	    unless defined $pedantic_tag;

    # FIXME: The line number is not accurate, but should be "close enough"
    # FIXME: This wording is worse than what was there, but it's wrong to
    # FIXME: hard-code this thing in each warn statement. Need improvement.
    return "$appName: $prefix: " . (defined $lc? "$input_abbr: line $lc: ": defined $input_abbr? "$input_abbr: ": '');
}

sub warn_additional {
    my($msg, $lc) = @_;
    my $prefix = construct_warn_prefix('Warning', $lc);
    $msg .= "\n" unless $msg =~ /\n$/s;
    warn "$prefix$msg";
}

sub warn_normal {
    my($msg, $lc) = @_;
    $warned += 1;
    warn_additional($msg, $lc);
}

sub warn_pedantic {
    my($msg, $lc, $flag) = @_;
    my $prefix = construct_warn_prefix("Warning$pedantic_tag", $lc);
    $msg .= "\n" unless $msg =~ /\n$/s;
    warn "$prefix$msg" if ($pedantic_p || !$$flag) && $quiet;
    if (!$pedantic_p) {
	$prefix = construct_warn_prefix("Warning$pedantic_tag", undef);
	warn $prefix."Further similar negligible warnings will not be reported, use --pedantic for details\n" unless ($$flag || !$quiet);
	$$flag = 1;
    }
    $warned += 1;
}

sub error_additional {
    my($msg, $lc) = @_;
    my $prefix = construct_warn_prefix('ERROR', $lc);
    $msg .= "\n" unless $msg =~ /\n$/s;
    warn "$prefix$msg";
}

sub error_normal {
    my($msg, $lc) = @_;
    $erred += 1;
    error_additional($msg, $lc);
}

sub warned {
    return $warned; # number of times warned
}

1;

###############################################################################