#------------------------------------------------------------------------------
#$Author: antanas $
#$Date: 2019-11-15 17:58:23 +0200 (Fri, 15 Nov 2019) $ 
#$Revision: 7411 $
#$URL: svn://www.crystallography.net/cod-tools/tags/v2.8/src/lib/perl5/COD/UserMessage.pm $
#------------------------------------------------------------------------------
#*
#  Format run time error and warning messages in a uniform way.
#**

package COD::UserMessage;

use strict;
use warnings;
use List::Util qw( max );

require Exporter;
our @ISA = qw( Exporter );
our @EXPORT_OK = qw(
    print_message
    error
    warning
    note
    parse_message
    sprint_message
    debug_note
);

# characters that will be escaped as HTML5 entities
# TODO: an escape strategy that cover the entirety of symbols that are not
# allowed should be implemented
my %common_escape = ( '&' => '&amp;', ':' => '&colon;', "\n" => '&#10;', );
my %ws_escape     = ( ' ' => '&nbsp;', "\t" => '&Tab;', );

my %program_escape  = ( %common_escape,
                        '(' => '&lpar;',   ')' => '&rpar;',
                        '{' => '&lbrace;', '}' => '&rbrace;',
                        '[' => '&lbrack;', ']' => '&rbrack;', );
my %filename_escape = ( %program_escape, %ws_escape );
my %add_pos_escape  = ( %common_escape );
my %message_escape  = ( %common_escape );

#==============================================================================
# Print a message, reporting a program name, file name, data block
# name and the error level (i.e., ERROR) in a uniform way.

sub sprint_message($$$$$$@)
{
    my ( $program, $filename, $add_pos, $err_level, $message,
         $explanation, $line, $column, $line_contents ) = @_;

    $message =~ s/\.?\n?$//;
    $explanation =~ s/\.?\n?$// if defined $explanation;

    #$program = "perl -e '...'" if ( $program eq '-e' );

    $program     = escape_meta( $program,     \%program_escape  );
    $filename    = escape_meta( $filename,    \%filename_escape );
    $add_pos     = escape_meta( $add_pos,     \%add_pos_escape  );
    $message     = escape_meta( $message,     \%message_escape  );
    $explanation = escape_meta( $explanation, \%message_escape  );

    $line_contents = prefix_multiline($line_contents);

    return $program . ':' .
           (defined $filename ? ' ' . $filename .
                (defined $line ? "($line" .
                    (defined $column ? ",$column" : '') . ')'
                : '') .
                (defined $add_pos ? " $add_pos" : '')
           : '') . ': ' .
           (defined $err_level ? $err_level . ', ' : '') .
           $message .
           (defined $explanation ? ' -- ' . $explanation : '') .
           (defined $line_contents ? ":\n" . $line_contents . "\n" .
                (defined $column ? ' ' . ' ' x max( 0, $column-1 ) . "^\n" : '')
                : ".\n");}

#==============================================================================
# Generic function for printing messages to STDERR

sub print_message($$$$$$@)
{
    my ( $program, $filename, $add_pos, $err_level, $message,
         $explanation, $line, $column, $line_contents ) = @_;
    print STDERR sprint_message( $program, $filename, $add_pos, $err_level,
                                 $message, $explanation, $line, $column,
                                 $line_contents );
}

#==============================================================================
# Parse an error message, generated by print_message. To be parsed
# correctly, program, file and data block names as well as error level must
# not not contain colons (':'). Error level is confined to uninterrupted
# word without colons and commas (','). Error level can be separated from
# the rest of the message by colon.
sub parse_message($)
{
    my( $message ) = @_;

    my $program   = qr/[A-Za-z0-9_,-.\/&;# \t]+/;
    my $file_name = qr/[A-Za-z0-9_,-.\/&;#]+/;
    my $err_level = qr/[A-Z][A-Z_0-9 ]*/ms;
    if( $message =~ /^
             ($program):[ ]?
             (?:
                 ($file_name)
                     (?: \( ([0-9]+) (?:,([0-9]+))? \) )?
                     (?: [ ]([^:]+?) )?
             )?
             :[ ]?
             (?: ($err_level)[,][ ])?
             (?:([^\n:]+?)(?:\.?\n?)?)
             (?: \: \s* \n
                 (
                 (?: [ ][^\n]*\n )*
                 )
             )?
         $/msxg ) {
        return {
            program      => unescape_meta($1, \%program_escape),
            filename     => unescape_meta($2, \%filename_escape),
            line_no      => $3,
            column_no    => $4,
            add_pos      => unescape_meta($5, \%add_pos_escape),
            err_level    => $6,
            message      => unescape_meta($7, \%message_escape),
            line_content => unprefix_multiline($8)
        };
    }

    return;
}

#==============================================================================
# Report an error message. Errors are indicated with the "ERROR"
# keyword in the message line. This is supposed to be a fatal even,
# and the program will most probably die() or exit(255) after this
# message, but the UserMessage package does not enforce this policy.

sub error($$$$$)
{
    my ( $program, $filename, $add_pos, $message, $explanation ) = @_;
    print_message( $program, $filename, $add_pos,
                   'ERROR', $message, $explanation );
}

#==============================================================================
# Report a warning message. Warnings are indicated with the "WARNING"
# keyword. Program can probably continue after warnings and give a
# reasonable result, but it might be not the result which the user
# expected.

sub warning($$$$$)
{
    my ( $program, $filename, $add_pos, $message, $explanation ) = @_;
    print_message( $program, $filename, $add_pos,
                   'WARNING', $message, $explanation );
}

#==============================================================================
# Report a note message. Notes are indicated with the "NOTE"
# keyword. Program can always continue after issuing notes as the intent
# of note is just to provide information on the progress.

sub note($$$$$)
{
    my ( $program, $filename, $add_pos, $message, $explanation ) = @_;
    print_message( $program, $filename, $add_pos,
                   'NOTE', $message, $explanation );
}

#==============================================================================
# Report a debug message. Notes are indicated with the "DEBUG"
# keyword. Debug messages should only be printed uppon user request to output
# additional information.

sub debug_note($$$$$)
{
    my ( $program, $filename, $add_pos, $message, $explanation ) = @_;
    print_message( $program, $filename, $add_pos,
                   'DEBUG', $message, $explanation );
}

sub escape_meta {
    my ( $text, $escaped_symbols ) = @_;

    return undef if !defined $text;

    my $symbols = join '|', map { '\\' . $_ } keys %{$escaped_symbols};

    $text =~ s/($symbols)/$escaped_symbols->{"$1"}/g;

    return $text;
}

sub unescape_meta {
    my ( $text, $escaped_symbols ) = @_;

    return undef if !defined $text;

    my %unescaped_symbols = reverse %{$escaped_symbols};

    my $symbols = join '|', keys %unescaped_symbols;

    $text =~ s/($symbols)/$unescaped_symbols{"$1"}/g;

    return $text;
}

sub prefix_multiline
{
    my ($multiline) = @_;

    if( defined $multiline ) {
        # Empty line has to be dealt separately, as split'ting empty
        # line returns empty array:
        if( $multiline ne '' ) {
            $multiline = join( "\n", map { " $_" }
                                         split( "\n", $multiline ) );
        } else {
            $multiline = ' ';
        }
    }

    return $multiline;
}

sub unprefix_multiline
{
    my ($multiline) = @_;

    $multiline =~ s/^ //msg if defined $multiline;

    return $multiline;
}

1;
