package VerboseWarnings;

use Modern::Perl;
use base 'Exporter';

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

=head1 NAME

VerboseWarnings.pm - Verbose warnings for Perl scripts

=head1 DESCRIPTION

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

=cut

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;
