usr/share/texinfo/Texinfo/Report.pm

# Report.pm: prepare error messages and translate strings.
#
# Copyright 2010, 2011, 2012, 2014 Free Software Foundation, Inc.
# 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 3 of the License,
# or (at your option) any later version.
# 
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
# 
# You should have received a copy of the GNU General Public License
# along with this program.  If not, see <http://www.gnu.org/licenses/>.
# 
# Original author: Patrice Dumas <pertusus@free.fr>

require Exporter;
use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS);
@ISA = qw(Exporter);

# Items to export into callers namespace by default. Note: do not export
# names by default without a very good reason. Use EXPORT_OK instead.
# Do not simply export all your public functions/methods/constants.

# This allows declaration      use Texinfo::Parser ':all';
# If you do not need this, moving things directly into @EXPORT or @EXPORT_OK
# will save memory.
%EXPORT_TAGS = ( 'all' => [ qw(
  errors
  gdt
) ] );

@EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } );

@EXPORT = qw(
);

package Texinfo::Report;

use 5.00405;
use strict;

# for fileparse
use File::Basename;

use Locale::Messages;
# to be able to load a parser if none was given to gdt.
use Texinfo::Parser;

# return the errors and warnings
sub errors($)
{
  my $self = shift;
  #print STDERR "REPORT ERRORS $self $self->{'errors_warnings'}\n";
  return ($self->{'errors_warnings'}, $self->{'error_nrs'});
}

sub __($$)
{
  my $self = shift;
  return &{$self->{'gettext'}}(@_);
}

sub __p($$$)
{
  my $self = shift;
  return &{$self->{'pgettext'}}(@_);
}

sub new($)
{
  my $self = shift;
  $self->{'errors_warnings'} = [];
  #print STDERR "REPORT NEW $self $self->{'errors_warnings'}\n";
  $self->{'errors_nrs'} = 0;
  $self->{'gettext'} = sub {return $_[0];} if (!defined($self->{'gettext'}));
  $self->{'pgettext'} = sub {return $_[1];} if (!defined($self->{'pgettext'}));
  return $self;
}

# format a line warning
sub line_warn($$$)
{
  my $self = shift;
  my $text = shift;
  chomp ($text);
  my $line_number = shift;
  return if (!defined($line_number) or $self->{'ignore_notice'});
  my $file = $line_number->{'file_name'};
  # otherwise out of source build fail since the file names are different
  my ($directories, $suffix);
  ($file, $directories, $suffix) = fileparse($file)
    if ($self->get_conf('TEST'));
  my $warn_line;
  if ($line_number->{'macro'} ne '') {
    $warn_line = sprintf($self->__p("Texinfo source file warning",
                             "%s:%d: warning: %s (possibly involving \@%s)\n"),
             $file, $line_number->{'line_nr'}, $text, $line_number->{'macro'});
  } else {
    $warn_line = sprintf($self->__p("Texinfo source file warning", 
                                    "%s:%d: warning: %s\n"),
                         $file, $line_number->{'line_nr'}, $text);
  }
  warn $warn_line if ($self->get_conf('DEBUG'));
  push @{$self->{'errors_warnings'}},
       { 'type' => 'warning', 'text' => $text, 'error_line' => $warn_line,
         %{$line_number} };
}

# format a line error
sub line_error($$$;$)
{
  my $self = shift;
  my $text = shift;
  chomp ($text);
  my $line_number = shift;
  my $continuation = shift;
  return if ($self->{'ignore_notice'});
  if (defined($line_number)) {
    my $file = $line_number->{'file_name'};
    my ($directories, $suffix);
    ($file, $directories, $suffix) = fileparse($file)
       if ($self->get_conf('TEST'));
    my $macro_text = '';
    $macro_text = " (possibly involving \@$line_number->{'macro'})"
       if ($line_number->{'macro'} ne '');
    my $error_text = "$file:$line_number->{'line_nr'}: $text$macro_text\n";
    warn "$error_text" if ($self->get_conf('DEBUG'));
    my $type = 'error';
    $type = 'error continuation' if ($continuation);
    push @{$self->{'errors_warnings'}},
         { 'type' => $type, 'text' => $text, 'error_line' => $error_text,
           %{$line_number} };
  }
  $self->{'error_nrs'}++ unless ($continuation);
}

sub document_warn($$)
{
  my $self = shift;
  my $text = shift;
  return if ($self->{'ignore_notice'});
  chomp($text);

  my $warn_line;
  if (defined($self->get_conf('PROGRAM')) and $self->get_conf('PROGRAM') ne '') {
    $warn_line = sprintf($self->__p("whole document warning", "%s: warning: %s\n"), 
                         $self->get_conf('PROGRAM'), $text);
  } else {
    $warn_line = sprintf($self->__p("whole document warning", "warning: %s\n"), 
                         $text);
  }
  push @{$self->{'errors_warnings'}},
    { 'type' => 'warning', 'text' => $text, 'error_line' => $warn_line };
}

sub document_error($$)
{
  my $self = shift;
  my $text = shift;
  return if ($self->{'ignore_notice'});
  chomp($text);
  my $error_line;
  if (defined($self->get_conf('PROGRAM')) and $self->get_conf('PROGRAM') ne '') {
    $error_line = sprintf("%s: %s\n", $self->get_conf('PROGRAM'), $text);
  } else {
    $error_line = "$text\n";
  }
  push @{$self->{'errors_warnings'}},
    { 'type' => 'error', 'text' => $text, 'error_line' => $error_line };
  $self->{'error_nrs'}++;
}

sub file_line_warn($$$;$)
{
  my $self = shift;
  my $text = shift;
  return if ($self->{'ignore_notice'});
  chomp($text);
  my $file = shift;
  my $line_nr = shift;

  my $warn_line;
  if (!defined($file)) {
    $warn_line = sprintf($self->__p("file warning", "warning: %s\n"), $text);
  } elsif (!defined($line_nr)) {
    $warn_line = sprintf($self->__p("file warning", "%s: warning: %s\n"), 
                         $file, $text);
  } else {
    $warn_line = sprintf($self->__p("file warning", "%s:%d: warning: %s\n"), 
                         $file, $line_nr, $text);
  }
  #print STDERR "REPORT FILE_LINE_WARN $self $self->{'errors_warnings'}\n";
  push @{$self->{'errors_warnings'}},
    { 'type' => 'warning', 'text' => $text, 'error_line' => $warn_line};
}

sub file_line_error($$$;$)
{
  my $self = shift;
  my $text = shift;
  return if ($self->{'ignore_notice'});
  chomp($text);
  my $file = shift;
  my $line_nr = shift;

  my $error_line;
  if (!defined($file)) {
    $error_line = "$text\n";
  } elsif (!defined($line_nr)) {
    $error_line = "$file: $text\n";
  } else {
    $error_line = "$file:$line_nr: $text\n";
  }
  #print STDERR "REPORT FILE_LINE_WARN $self $self->{'errors_warnings'}\n";
  push @{$self->{'errors_warnings'}},
    { 'type' => 'error', 'text' => $text, 'error_line' => $error_line};
  $self->{'error_nrs'}++;
}


# i18n

my $DEFAULT_LANGUAGE = 'en';

# we want a reliable way to switch locale, so we don't use the system
# gettext.
Locale::Messages->select_package ('gettext_pp');

# FIXME make those configurable?  Set them with call to new?
my $strings_textdomain = 'texinfo_document';
my $messages_textdomain = 'texinfo';

# libintl converts between encodings but doesn't decode them into the
# perl internal format.  This is only called if the encoding is a proper
# perl encoding.
sub _encode_i18n_string($$)
{
  my $string = shift;
  my $encoding = shift;
  return Encode::decode($encoding, $string);
}

# handle translations of in-document strings.
sub gdt($$;$$)
{
  my $self = shift;
  my $message = shift;
  my $context = shift;
  my $type = shift;

  my $re = join '|', map { quotemeta $_ } keys %$context
      if (defined($context) and ref($context));

  my $saved_env_LC_ALL = $ENV{'LC_ALL'};
  my $saved_LANGUAGE = $ENV{'LANGUAGE'};
#  my $saved_LANG = $ENV{'LANG'};
#  my $saved_LC_ALL = POSIX::setlocale (LC_ALL);
#  my $saved_LC_CTYPE = POSIX::setlocale (LC_CTYPE);
#  my $saved_LC_MESSAGES = POSIX::setlocale (LC_MESSAGES);

  Locale::Messages::textdomain($strings_textdomain);

  # FIXME do that only once when encoding is seen (or at beginning)
  # instead of here, each time that gdt is called?
  my $encoding;
  if ($self->get_conf('OUTPUT_ENCODING_NAME')) {
    $encoding = $self->get_conf('OUTPUT_ENCODING_NAME');
  } elsif ($self->get_conf('INPUT_ENCODING_NAME')) {
    $encoding = $self->get_conf('INPUT_ENCODING_NAME');
  }
  Locale::Messages::bind_textdomain_codeset($strings_textdomain, $encoding)
    if ($encoding and $encoding ne 'us-ascii');
  if (!($encoding and $encoding eq 'us-ascii')) {
    my $perl_encoding;
    if ($self->get_conf('OUTPUT_PERL_ENCODING')) {
      $perl_encoding = $self->get_conf('OUTPUT_PERL_ENCODING');
    } elsif ($self->get_conf('INPUT_PERL_ENCODING')) {
      $perl_encoding = $self->get_conf('INPUT_PERL_ENCODING');
    }
    if ($perl_encoding) {
      Locale::Messages::bind_textdomain_filter($strings_textdomain,
        \&_encode_i18n_string, $perl_encoding);
    }
  }

  # FIXME do that once when @documentlanguage changes (or at beginning)
  # instead of here, each time that gdt is called?
  my $lang = $self->get_conf('documentlanguage');
  $lang = $DEFAULT_LANGUAGE if (!defined($lang));
  my @langs = ($lang);
  if ($lang =~ /^([a-z]+)_([A-Z]+)/) {
    my $main_lang = $1;
    my $region_code = $2;
    push @langs, $main_lang;
  }

  my $locales = '';

  foreach my $language (@langs) {
    if ($encoding) {
      $locales .= "$language.$encoding:";
    } else {
      $locales .= "$language:";
    }
    # always try us-ascii, the charset should always be a subset of
    # all charset, and should resort to @-commands if needed for non
    # ascii characters
    if (!$encoding or ($encoding and $encoding ne 'us-ascii')) {
      $locales .= "$language.us-ascii:";
    }
  }
  $locales =~ s/:$//;
  # print STDERR "$locales $message\n";
  # END FIXME

  Locale::Messages::nl_putenv("LANGUAGE=$locales");

  my $translation_result;
  if (!defined($context) or ref($context)) {
    $translation_result = Locale::Messages::gettext($message);
  } else {
    # In practice this is not used anywhere, context is always a HASH.
    # for strings substitution not a context for translation.
    $translation_result = Locale::Messages::pgettext($context, $message);
  }
  #print STDERR "$locales $message ----> $translation_result\n";

  Locale::Messages::textdomain($messages_textdomain);
  # old perl complains 'Use of uninitialized value in scalar assignment'
  if (!defined($saved_LANGUAGE)) {
    delete ($ENV{'LANGUAGE'});
  } else {
    $ENV{'LANGUAGE'} = $saved_LANGUAGE;
  }
  if (!defined($saved_env_LC_ALL)) {
    delete ($ENV{'LC_ALL'});
  } else {
    $ENV{'LC_ALL'} = $saved_env_LC_ALL;
  }
#  my $new_LC_ALL = POSIX::setlocale (LC_ALL);
#  my $new_LC_CTYPE = POSIX::setlocale (LC_CTYPE);
#  my $new_LC_MESSAGES = POSIX::setlocale (LC_MESSAGES);
#  my $new_env_LC_ALL = 'UNDEF';
#  $new_env_LC_ALL = $ENV{'LC_ALL'} if defined($ENV{'LC_ALL'});
#  my $saved_str_env_LC_ALL = $saved_env_LC_ALL;
#  $saved_str_env_LC_ALL = 'UNDEF' if (!defined($saved_str_env_LC_ALL));

#  print STDERR "  LC_ALL $saved_LC_ALL $new_LC_ALL ENV: $saved_str_env_LC_ALL $new_env_LC_ALL\n";
#  print STDERR "  LC_CTYPE $saved_LC_CTYPE $new_LC_CTYPE\n";
#  print STDERR "  LC_MESSAGES $saved_LC_MESSAGES $new_LC_MESSAGES\n";
#  my $new_LANG = 'UNDEF';
#  $new_LANG = $ENV{'LANG'} if defined($ENV{'LANG'});
#  my $saved_str_LANG = $saved_LANG;
#  $saved_str_LANG = 'UNDEF' if (!defined($saved_str_LANG));
#  print STDERR "  LANG $saved_str_LANG $new_LANG\n";

  if ($type and $type eq 'translated_text') {
    if (defined($re)) {
      # next line taken from libintl perl, copyright Guido. sub __expand
      $translation_result =~ s/\{($re)\}/defined $context->{$1} ? $context->{$1} : "{$1}"/ge;
    }
    return $translation_result;
  }

  my $parser_conf;
  # we change the substituted brace-enclosed strings to values, that
  # way they are substituted, including when they are Texinfo trees.
  # a _ is prepended to avoid clashing with other values, although since
  # the parser is a new one there should not be any problem anyway.
  if (defined($re)) {
    # next line taken from libintl perl, copyright Guido. sub __expand
    $translation_result =~ s/\{($re)\}/\@value\{_$1\}/g;
    foreach my $substitution(keys %$context) {
      #print STDERR "$translation_result $substitution $context->{$substitution}\n";
      $parser_conf->{'values'}->{'_'.$substitution} = $context->{$substitution};
    }
  }

  # Don't reuse the current parser itself, as (tested) the parsing goes 
  # wrong, certainly because the parsed text can affect the parser state.
  my $current_parser;
  if (ref($self) eq 'Texinfo::Parser') {
    $current_parser = $self;
  } elsif ($self->{'parser'}) {
    $current_parser = $self->{'parser'};
  }

  if ($current_parser) {
    # not sure 'gettext' could in fact be useful in parser for
    # translated fragments.  'TEST' can be used fot @today{} expansion.
    foreach my $duplicated_conf ('clickstyle', 'kbdinputstyle', 'DEBUG',
                                 'TEST', 'gettext') {
      $parser_conf->{$duplicated_conf} = $current_parser->{$duplicated_conf}
        if (defined($current_parser->{$duplicated_conf}));
    }
  }
  #my $parser = Texinfo::Parser::parser($parser_conf);
  my $parser = Texinfo::Parser::simple_parser($parser_conf);
  if ($parser->{'DEBUG'}) {
    print STDERR "GDT $translation_result\n";
  }

  my $tree;
  # Right now this is not used anywhere.
  if ($type and $type eq 'translated_paragraph') {
    $tree = $parser->parse_texi_text($translation_result);
  } else {
    $tree = $parser->parse_texi_line($translation_result);
  }
  return $tree;
}


1;

__END__

=head1 NAME

Texinfo::Report - Error storing and string translations for Texinfo modules

=head1 SYNOPSIS

  @ISA = qw(Texinfo::Report);

  $converter->Texinfo::Report::new();
  
  if ($warning_happened) {
    $converter->line_warn(sprintf($converter->__("\@%s is wrongly used"),
                       $current->{'cmdname'}), $current->{'line_nr'});
  }
  
  my ($errors, $errors_count) = $converter->errors();
  foreach my $error_message (@$errors) {
    warn $error_message->{'error_line'};
  }

  my $tree_translated = $converter->gdt('See {reference} in @cite{{book}}',
                       {'reference' => $tree_reference,
                        'book'  => {'text' => $book_name}});


=head1 DESCRIPTION

The Texinfo::Report module helps with string translations and error 
handling.  It is used by the Texinfo modules Texinfo::Parser and 
Texinfo::Convert::Converter.  To use this module, the usual way is
to inherit Texinfo::Report methods and initialize the Texinfo::Report
variables for a I<$converter> object. This is done by calling 
C<Texinfo::Report::new()> on the I<$converter> object.  This is done by 
Texinfo::Convert::Converter, for instance, so every module that inherits
Texinfo::Convert::Converter can automatically use the Texinfo::Report
methods in an object-oriented way.

Besides the C<new> method, C<gdt> is used for string translations, 
C<errors> for reporting errors, and the other methods to store errors
(and warnings).

=head1 METHODS

No method is exported in the default case.  

The C<new> method initializes Texinfo::Report related fields:

  $converter->Texinfo::Report::new()

The C<gdt> method is used to translate strings to be output in 
converted documents, and return a texinfo tree.

=over

=item $tree = $converter->gdt($string, $replaced_substrings, $mode)

The I<$string> is a string to be translated.  In the default case, 
the function returns a Texinfo tree, as the string is 
interpreted as Texinfo code after
translation.  I<$replaced_substrings> is an optional 
hash reference specifying some 
substitution to be done after the translation.  The key of 
the I<$replaced_substrings> hash reference identifies what is to 
be substituted, and the value is some string, texinfo tree or array content 
that is substituted in the resulting texinfo tree.
In the string to be translated word in brace matching keys of 
I<$replaced_substrings> are replaced.

I<$mode> is an optional string which may modify how the function
behaves.  The possible values are

=over 

=item translated_text

In that case the string is not considered to be Texinfo, a plain string
that is returned after translation and substitution.  The substitutions
may only be strings in that case.

=item translated_paragraph

In that case, the parsing of the Texinfo string is done in a 
context of a paragraph, not in the context of an inline text.

=back

For example in the following call, the string 
I<See {reference} in @cite{{book}}> is translated, then
parsed as a Texinfo string, with I<{reference}> substituted by
I<$tree_reference> in the resulting tree, and I<{book}> 
replaced by the associated texinfo tree text element:

  $tree = $converter->gdt('See {reference} in @cite{{book}}',
                       {'reference' => $tree_reference,
                        'book'  => {'text' => $book_name}});

C<gdt> uses the information in the I<$converter> to know the
encoding and documentlanguage.  More precisely, 
C<< $converter->{'encoding_name'} >>, C<< $converter->{'perl_encoding'} >>
and C<< $converter->get_conf('documentlanguage') >> are used.

C<gdt> uses a gettext-like infrastructure to retrieve the 
translated strings, using the I<texinfo_document> domain.

=back

The errors collected are available through the C<errors> method, the other
methods allow registering errors and warnings.

=over

=item ($error_warnings_list, $error_count) = errors ($converter)

This function returns as I<$error_count> the count of errors since
calling C<new>.  The I<$error_warnings_list> is an array of hash references
one for each error, warning or error line continuation.  Each of these has 
the following keys:

=over

=item type

May be C<warning>, C<error>, or C<error continuation> (for a continuation of
an error line).

=item text

The text of the error.

=item error_line

The text of the error formatted with the file name, line number and macro
name, as needed.

=item line_nr

The line number of the error or warning.

=item file_name

The file name where the error or warning occurs.

=item macro

The user macro name that is expanded at the location of 
the error or warning.

=back

=item $converter->line_warn($text, $line_nr)

=item $converter->line_error($text, $line_nr, $continuation)

Register a warning or an error.  The I<$text> is the text of the
error or warning.  The optional I<$line_nr> holds the information
on the error or warning location.  It is associated with the I<line_nr> 
key of Texinfo tree elements as described in L<Texinfo::Parser/line_nr>
for the @-commands.  The I<$line_nr> structure is described in L<errors|($error_warnings_list, $error_count) = errors ($converter)>
above.  If I<$continuation> is set, the line is an error message continuation
line and not a new error.

=item $converter->document_warn($text)

=item $converter->document_error($text)

Register a document-wide error or warning.  I<$text> is the error or
warning message.

=item $converter->file_line_warn($text, $file, $line_nr)

Register the warning message I<$text> for file I<$file>, with, optionally
the line I<$line_nr> in the file.

=item $converter->file_line_error($text, $file, $line_nr)

Register the error message I<$text> for file I<$file>, with, optionally
the line I<$line_nr> in the file.

=back

=head1 AUTHOR

Patrice Dumas, E<lt>pertusus@free.frE<gt>

=head1 COPYRIGHT AND LICENSE

Copyright 2010, 2011, 2012 Free Software Foundation, Inc.

This library is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 3 of the License,
or (at your option) any later version.

=cut