code:
# IXIN.pm: output tree as IXIN.
#
# Copyright 2013 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>
#
# This module implements abstract functions that output the IXIN format
# using lower level formatting funtions, here adapted to lisp like
# output.  For other output, the output specific functions should be
# redefined.  This module is not enough to output IXIN format, a module
# inheriting both from a converter module and this module is required.

package Texinfo::Convert::IXIN;

use 5.00405;
use strict;

use MIME::Base64;
use Texinfo::Convert::TexinfoSXML;
use Texinfo::Common;

use Carp qw(cluck);

require Exporter;
use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS);
@ISA = qw(Exporter Texinfo::Convert::Converter);

# 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::Convert::IXIN ':all';
# If you do not need this, moving things directly into @EXPORT or @EXPORT_OK
# will save memory.
%EXPORT_TAGS = ( 'all' => [ qw(
  output_ixin
) ] );

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

@EXPORT = qw(
);

$VERSION = '6.3.90';

my $ixin_version = 1;

sub _ixin_version($)
{
  my $self = shift;
  return $ixin_version;
}

my %additional_setting_commands;
# FIXME pagesizes is line
foreach my $command ('pagesizes', 'everyheading', 'everyfooting',
                     'evenheading', 'evenfooting', 'oddheading', 'oddfooting',
                     'documentencoding', 'documentlanguage', 'clickstyle') {
  $additional_setting_commands{$command} = 1;
}

# Here are all the commands that are misc_commands with type matching \d
# and are also global_unique_commands/global_multiple_commands in Parser.pm
# but are not setting commands.
my %global_misc_not_setting_commands = (
  'printindex' => 1,
);

my @image_files_extensions = ('eps', 'gif', 'jpg', 'jpeg', 'pdf', 'png', 'svg',
                              'txt');
my %extension_mime_mapping = (
  'eps' => 'application/postscript',
  'gif' => 'image/gif',
  'jpg' => 'image/jpeg',
  'jpeg' => 'image/jpeg',
  'pdf' => 'application/pdf',
  'png' => 'image/png',
  'svg' => 'image/svg+xml',
  'txt' => 'text/plain',
  'tiff' => 'image/tiff',
  '' => 'image/unknown',
);

# output specific
sub ixin_header($)
{
  my $self = shift;
  my $header = 'ixin '.$self->_ixin_version().';';
  if ($self->get_conf('OUTPUT_ENCODING_NAME')) {
    $header .= ' -*- coding: '. $self->get_conf('OUTPUT_ENCODING_NAME') .'-*-;';
  }
  $header .= "\n";
}

my %attribute_string_names = (
  'nodeentry' => {'name' => 1},
  'nodelabel' => {'name' => 1},
  'floatentry' => {'name' => 1},
  'label' => {'name' => 1},
  'filename' => {'name' => 1},
  'settingvalue' => {'value' => 1},
  'nodetweakvalue' => {'value' => 1},
  'floatindex' => {'type' => 1},
  'blobentry' => {'mimetype' => 1, 'filename' => 1},
);

sub _ixin_attributes($$$)
{
  my $self = shift;
  my $name = shift;
  my $attributes = shift;
  my $result = '';
  if ($attributes) {
    for (my $i = 0; $i < scalar(@$attributes); $i += 2) {
      if ($attribute_string_names{$name}
          and $attribute_string_names{$name}->{$attributes->[$i]}) {
        $result .= '"'
          .Texinfo::Convert::TexinfoSXML->protect_text($attributes->[$i+1]).'"';
      } else {
        $result .= $attributes->[$i+1];
      }
      $result .= ' ';
    }
  }
  return $result;
}

sub ixin_open_element($$;$)
{
  my $self = shift;
  my $name = shift;
  my $attributes = shift;
  my $result = '(';
  $result .= $self->_ixin_attributes($name, $attributes);
  return $result;
}

sub ixin_list_element($$$)
{
  my $self = shift;
  my $name = shift;
  my $attributes = shift;
  my $result = $self->_ixin_attributes($name, $attributes);
  $result =~ s/ $//;
  return $result;
}

sub ixin_close_element($$)
{
  my $self = shift;
  my $name = shift;
  return ')';
  #return "|$name)";
}

sub ixin_element($$;$)
{
  my $self = shift;
  my $name = shift;
  my $attributes = shift;
  my $opening = $self->ixin_open_element($name, $attributes);
  $opening =~ s/ $//;
  return $opening . $self->ixin_close_element($name);
}

sub ixin_symbol_element($$$)
{
  my $self = shift;
  my $name = shift;
  my $string = shift;
  return $string;
}

sub ixin_none_element($$)
{
  my $self = shift;
  my $name = shift;
  return ' - ';
}

# end output specific subs

# FIXME this is rather non specific. Move to Converter?
sub _get_element($$);
sub _get_element($$)
{
  my $self = shift;
  my $current = shift;

  my ($element, $root_command);
  while (1) {
    #print STDERR Texinfo::Common::_print_current($current);
    if ($current->{'type'}) {
      if ($current->{'type'} eq 'element') {
        return ($current, $root_command);
      }
    }
    if ($current->{'cmdname'}) {
      if ($Texinfo::Common::root_commands{$current->{'cmdname'}}) {
        $root_command = $current;
        return ($element, $root_command) if defined($element);
      }
    }
    if ($current->{'parent'}) {
      $current = $current->{'parent'};
    } else {
      return ($element, $root_command);
    }
  }
}

sub _count_bytes($$)
{
  my $self = shift;
  my $string = shift;

  return Texinfo::Common::count_bytes($self, $string);
}

sub _associated_node_id($$$;$)
{
  my $self = shift;
  my $command = shift;
  my $node_label_number = shift;
  my $node_command = shift;

  if (!defined($node_command)) {
    my ($element, $root_command) = $self->_get_element($command);

    if ($root_command) {
      if (!$root_command->{'cmdname'} or $root_command->{'cmdname'} ne 'node') {
        if ($element->{'extra'}->{'element_command'}
            and $element->{'extra'}->{'element_command'}
            and $element->{'extra'}->{'element_command'}->{'cmdname'}
            and $element->{'extra'}->{'element_command'}->{'cmdname'} eq 'node') {
          $node_command = $element->{'extra'}->{'element_command'};
        }
      } else {
        $node_command = $root_command;
      }
    }
  }
  my $associated_node_id;
  if (defined($node_command)
      and defined($node_command->{'extra'}->{'normalized'})) {
    $associated_node_id
      = $node_label_number->{$node_command->{'extra'}->{'normalized'}};
  } else {
    $associated_node_id = -1;
  }
  return $associated_node_id;
}

sub _index_font_name($$)
{
  my $self = shift;
  my $in_code = shift;
  if ($in_code) {
    return 'code';
  } else {
    return 'r';
  }
}

my @node_directions = ('Next', 'Prev', 'Up');

sub output_ixin($$)
{
  my $self = shift;
  my $root = shift;

  $self->_set_outfile();
  return undef unless $self->_create_destination_directory();

  my $fh;
  if (! $self->{'output_file'} eq '') {
    $fh = $self->Texinfo::Common::open_out($self->{'output_file'});
    if (!$fh) {
      $self->document_error(sprintf($self->__("could not open %s for writing: %s"),
                                    $self->{'output_file'}, $!));
      return undef;
    }
  }

  $self->_set_global_multiple_commands(-1);
  # we ignore everything before the first node
  $self->_set_ignored_type('text_root');

  my $result = $self->ixin_header();

  $result .= $self->ixin_open_element('meta');
  $result .= $self->ixin_open_element('xid');

  my $output_file = $self->ixin_none_element('filename');
  if ($self->{'output_file'} ne '') {
    $result .= $self->ixin_list_element('filename',
                           ['name', $self->{'output_file'}]);
  }
  my $lang = $self->get_conf('documentlanguage');
  #my $lang_code = $lang;
  #my $region_code;
  #if ($lang =~ /^([a-z]+)_([A-Z]+)/) {
  #  $lang_code = $1;
  #  $region_code = $2;
  #}
  $result .= ' ';
  $result .= $self->ixin_list_element('lang', ['name', $lang]);
  # FIXME title: use simpletitle or fulltitle

  if ($self->{'info'}->{'dircategory_direntry'}) {
    my $current_category;
    foreach my $dircategory_direntry (@{$self->{'info'}->{'dircategory_direntry'}}) {
      if ($dircategory_direntry->{'cmdname'} and $dircategory_direntry->{'cmdname'} eq 'dircategory') {
        if ($current_category) {
          $result .= $self->ixin_close_element('category');
        }
        $current_category = $dircategory_direntry;
        $result .= $self->ixin_open_element('category');
        # FIXME wait for Thien-Thi input on renderable or string.
      } elsif ($dircategory_direntry->{'cmdname'}
               and $dircategory_direntry->{'cmdname'} eq 'direntry') {
        # FIXME wait for Thien-Thi input on renderable or string and node
        # rendering
      }
    }
    if ($current_category) {
      $result .= $self->ixin_close_element('category');
    }
  }
  $result .= $self->ixin_close_element('xid');

  # FIXME vars: wait for Thien-Thi answer.

  my $elements = Texinfo::Structuring::split_by_node($root);
  # setting_commands is for @-commands appearing before the first node,
  # while end_of_nodes_setting_commands holds, for @-commands names, the
  # last @-command element.
  my %setting_commands;
  my %end_of_nodes_setting_commands;
  my %setting_commands_defaults;
  foreach my $global_command (keys(%{$self->{'extra'}})) {
    if ((($Texinfo::Common::misc_commands{$global_command}
          and $Texinfo::Common::misc_commands{$global_command} =~ /^\d/)
         or $additional_setting_commands{$global_command})
        and !$global_misc_not_setting_commands{$global_command}) {
      if (ref($self->{'extra'}->{$global_command}) eq 'ARRAY') {
        if (defined($Texinfo::Common::document_settable_at_commands{$global_command})) {
          $setting_commands_defaults{$global_command}
            = $Texinfo::Common::document_settable_at_commands{$global_command};
        }
        foreach my $command (@{$self->{'extra'}->{$global_command}}) {
          my ($element, $root_command) = _get_element($self, $command);
          # before first node
          if (!defined($root_command->{'extra'})
              and !defined($root_command->{'extra'}->{'normalized'})) {
            $setting_commands{$global_command} = $command;
          } else {
            # register the setting value at the end of the node
            $end_of_nodes_setting_commands{$root_command->{'extra'}->{'normalized'}}->{$global_command}
              = $command;
          }
          #print STDERR "$element $root_command->{'extra'} $global_command\n";
        }
      } else {
        if (defined($Texinfo::Common::document_settable_unique_at_commands{$global_command})) {
          $setting_commands_defaults{$global_command}
            = $Texinfo::Common::document_settable_unique_at_commands{$global_command};
        }
        $setting_commands{$global_command} = $self->{'extra'}->{$global_command};
      }
    }
  }
  my %settings;
  foreach my $setting_command_name (keys(%setting_commands)) {
    my $setting_command = $setting_commands{$setting_command_name};
    $setting_command_name = 'shortcontents'
        if ($setting_command_name eq 'summarycontents');
    my $value = $self->_informative_command_value($setting_command);
    #print STDERR "$setting_command_name $value\n";
    # do not register settings if sete at the default value.
    if (defined($value)
        and !(defined($setting_commands_defaults{$setting_command_name})
              and $setting_commands_defaults{$setting_command_name} eq $value)) {
      $settings{$setting_command_name} = $value;
    }
  }

  $result .= ' ';
  $result .= $self->ixin_open_element('settings');
  if (scalar(keys(%settings))) {
    foreach my $command_name (sort(keys(%settings))) {
      $result .= $self->ixin_open_element('setting');
      $result .= $self->ixin_symbol_element('settingname', $command_name);
      $result .= ' ';
      if ($Texinfo::Common::misc_commands{$command_name} eq 'lineraw') {
        $result .= $self->ixin_list_element('settingvalue',
                                   ['value', $settings{$command_name}]);
      } else {
        $result .= $self->ixin_symbol_element('settingvalue', $settings{$command_name});
      }
      $result .= $self->ixin_close_element('setting');
    }
  }
  $result .= $self->ixin_close_element('settings');

  foreach my $region ('copying', 'titlepage') {
    if ($self->{'extra'}->{$region}) {
      $result .= $self->convert_tree($self->{'extra'}->{$region});
    } else {
      $result .= $self->ixin_none_element($region);
    }
  }

  # FIXME toc: wait for Thien-Thi answer.

  $result .= $self->ixin_close_element('meta');
  $result .= "\n";

  # to do the nodes index, one need the size of each node.
  # to do the counts list, one need to know the sizze of the node index.
  # So we have to start by the node data.
  my $node_nr = 0;
  my %current_settings;
  my %node_label_number;
  my %node_byte_sizes;
  my %node_tweaks;
  my @nodes;
  my $document_output = '';
  if ($elements) {
    foreach my $node_element (@$elements) {
      next if ($node_element->{'extra'}->{'no_node'});
      $node_nr++;
      my $node = $node_element->{'extra'}->{'element_command'};
      push @nodes, $node;
      my $normalized_node_name = $node->{'extra'}->{'normalized'};
      foreach my $setting_command_name (keys(%current_settings)) {
        $node_tweaks{$normalized_node_name}->{$setting_command_name}
          = $current_settings{$setting_command_name};
      }
      $node_label_number{$normalized_node_name} = $node_nr;

      my $node_result = $self->convert_tree($node_element)."\n";
      $document_output .= $node_result;

      # get node length.
      $node_byte_sizes{$normalized_node_name}
         = $self->_count_bytes($node_result);
      # update current settings
      if (defined($end_of_nodes_setting_commands{$normalized_node_name})) {
        foreach my $setting_command_name (keys(%{$end_of_nodes_setting_commands{$normalized_node_name}})) {
          my $value = $self->_informative_command_value(
            $end_of_nodes_setting_commands{$normalized_node_name}->{$setting_command_name});
          if ((defined($settings{$setting_command_name})
               and $settings{$setting_command_name} eq $value)
              or (!defined($settings{$setting_command_name})
                  and defined($setting_commands_defaults{$setting_command_name})
                  and $setting_commands_defaults{$setting_command_name} eq $value)) {
            delete $current_settings{$setting_command_name};
          } else {
            $current_settings{$setting_command_name} = $value;
          }
        }
      }
    }
  } else {
    # not a full document.
  }

  my $nodes_index = $self->ixin_open_element('nodesindex');
  foreach my $node (@nodes) {
    my $normalized_node_name = $node->{'extra'}->{'normalized'};
    # FIXME name should be a renderable sequence
    my @attributes = ('name', $normalized_node_name,
                      'length', $node_byte_sizes{$normalized_node_name});
    foreach my $direction (@node_directions) {
      if ($node->{'node_'.lc($direction)}) {
        my $node_direction = $node->{'node_'.lc($direction)};
        if ($node_direction->{'extra'}->{'manual_content'}) {
          # FIXME?
          push @attributes, ('node'.lc($direction), -2);
        } else {
          push @attributes, ('node'.lc($direction),
                 $node_label_number{$node_direction->{'extra'}->{'normalized'}})
        }
      } else {
        push @attributes, ('node'.lc($direction), -1);
      }
    }
    $nodes_index .= $self->ixin_open_element('nodeentry', \@attributes);

    if ($node_tweaks{$normalized_node_name}) {
      $nodes_index .= $self->ixin_open_element('nodetweaks');
      foreach my $command_name (sort(keys(%{$node_tweaks{$normalized_node_name}}))) {
        $nodes_index .= $self->ixin_open_element('nodetweak');
        $nodes_index .= $self->ixin_symbol_element('nodetweakname', $command_name);
        $nodes_index .= ' ';
        if ($Texinfo::Common::misc_commands{$command_name} eq 'lineraw') {
          $nodes_index .= $self->ixin_list_element('nodetweakvalue',
            ['value', $node_tweaks{$normalized_node_name}->{$command_name}]);
        } else {
          $nodes_index .= $self->ixin_symbol_element('nodetweakvalue',
                       $node_tweaks{$normalized_node_name}->{$command_name});
        }
        $nodes_index .= $self->ixin_close_element('nodetweak');

      }
      $nodes_index .= $self->ixin_close_element('nodetweaks');
    }
    $nodes_index .= $self->ixin_close_element('nodeentry');
  }
  $nodes_index .= $self->ixin_close_element('nodesindex');
  $nodes_index .= "\n";

  # do sectioning tree
  my $sectioning_tree = '';
  $sectioning_tree  .= $self->ixin_open_element('sectioningtree');
  if ($self->{'structuring'} and $self->{'structuring'}->{'sectioning_root'}) {
    my $section_root = $self->{'structuring'}->{'sectioning_root'};
    foreach my $top_section (@{$section_root->{'section_childs'}}) {
      my $section = $top_section;
 SECTION:
      while ($section) {
        my $associated_node_id = $self->_associated_node_id($section,
                                                     \%node_label_number);
        my @attributes = ('nodeid', $associated_node_id, 'type',
              $self->_level_corrected_section($section));
        $sectioning_tree .= $self->ixin_open_element('sectionentry',
                 \@attributes);
        $sectioning_tree .= $self->ixin_open_element('sectiontitle');
        if ($section->{'args'} and $section->{'args'}->[0]) {
          $sectioning_tree .= $self->convert_tree($section->{'args'}->[0]);
        }
        $sectioning_tree .= $self->ixin_close_element('sectiontitle');
        # top is special and never considered to contain anything.  So
        # it is closed here and not below.
        if ($section->{'cmdname'} eq 'top') {
          $sectioning_tree .= $self->ixin_close_element('sectionentry');
        }
        if ($section->{'section_childs'}) {
          $section = $section->{'section_childs'}->[0];
        } elsif ($section->{'section_next'}) {
          $sectioning_tree .= $self->ixin_close_element('sectionentry');
          last if ($section eq $top_section);
          $section = $section->{'section_next'};
        } else {
          if ($section eq $top_section) {
            $sectioning_tree .= $self->ixin_close_element('sectionentry')
              unless ($section->{'cmdname'} eq 'top');
            last;
          }
          while ($section->{'section_up'}) {
            $section = $section->{'section_up'};
            $sectioning_tree .= $self->ixin_close_element('sectionentry');
            if ($section eq $top_section) {
              $sectioning_tree .= $self->ixin_close_element('sectionentry')
                 unless ($section->{'cmdname'} eq 'top');
              last SECTION;
            }
            if ($section->{'section_next'}) {
              $sectioning_tree .= $self->ixin_close_element('sectionentry');
              $section = $section->{'section_next'};
              last;
            }
          }
        }
      }
    }
  }
  $sectioning_tree  .= $self->ixin_close_element('sectioningtree') . "\n";

  # do labels

  my $non_node_labels_text = '';
  my $labels_nr = 0;
  my %floats_associated_node_id;
  if ($self->{'labels'}) {
    foreach my $label (sort(keys(%{$self->{'labels'}}))) {
      my $command = $self->{'labels'}->{$label};
      next if ($command->{'cmdname'} eq 'node');
      $labels_nr++;
      my $associated_node_id = $self->_associated_node_id($command,
                                                     \%node_label_number);
      $non_node_labels_text .= $self->ixin_element('label', ['name', $label,
                                       'nodeid', $associated_node_id,
                                       'type', $command->{'cmdname'}]);

      # register floats to avoid doing it twice for the float specific index
      if ($command->{'cmdname'} eq 'float') {
        $floats_associated_node_id{$command} = $associated_node_id;
      }
    }
  }

  my $labels_text = $self->ixin_open_element('labels', ['count', $labels_nr]);
  foreach my $node (@nodes) {
    $labels_text .= $self->ixin_list_element('nodelabel', ['name',
                                    $node->{'extra'}->{'normalized'}]);
    $labels_text .= ' ';
  }
  $labels_text .= $non_node_labels_text
                  . $self->ixin_close_element('labels')."\n";

  # do document-term sets (indices counts and indices)

  my %dts_information;

  if ($self->{'parser'}) {
    my $index_names = $self->{'parser'}->indices_information();
    my $merged_index_entries
        = Texinfo::Structuring::merge_indices($index_names);
    my $entries
      = $self->Texinfo::Structuring::sort_indices($merged_index_entries,
                                                  $index_names);
    # first do the dts_text as the counts are needed for the dts index
    foreach my $index_name (sort(keys(%$entries))) {
      my $dts_text_result = '';
      my $dts_entries_nr = 0;
      my $dts_in_code = $index_names->{$index_name}->{'in_code'};
      foreach my $dts_entry (@{$entries->{$index_name}}) {
        my $node = $dts_entry->{'node'};
        my $associated_node_id;
        if (defined($node)) {
          $associated_node_id = $self->_associated_node_id(undef,
                                                    \%node_label_number, $node);
        } else {
          $associated_node_id = -1;
        }
        my $entry = $self->convert_tree({'contents' => $dts_entry->{'content'}});
        $dts_text_result .= $self->ixin_open_element('dtsentry',
                                                ['nodeid', $associated_node_id]);
        $dts_text_result .= $self->ixin_open_element('dtsterm');
        $dts_text_result .= $entry;
        $dts_text_result .= $self->ixin_close_element('dtsterm');
        if ($dts_entry->{'in_code'} != $dts_in_code) {
          my $font_name = $self->_index_font_name($dts_entry->{'in_code'});
          $dts_text_result .= ' ';
          $dts_text_result .= $self->ixin_list_element('dtsfont', ['font',
                                                                   $font_name]);
        }
        $dts_text_result .= $self->ixin_close_element('dtsentry');
        $dts_entries_nr++;
      }
      my $dts_opening = $self->ixin_open_element('dts', ['count', $dts_entries_nr,
                                    'font', $self->_index_font_name($dts_in_code)]);
      $dts_text_result = $dts_opening . $dts_text_result
             . $self->ixin_close_element('dts') . "\n";
      $dts_information{$index_name}->{'dts_text'} = $dts_text_result;
    }
  }

  # Gather informations on printindex @-commands associated node id
  if ($self->{'extra'}->{'printindex'}) {
    foreach my $command (@{$self->{'extra'}->{'printindex'}}) {
      my $associated_node_id = $self->_associated_node_id($command,
                                                   \%node_label_number);
      if ($command->{'extra'} and $command->{'extra'}->{'misc_args'}
          and defined($command->{'extra'}->{'misc_args'}->[0])) {
        my $index_name = $command->{'extra'}->{'misc_args'}->[0];
        push @{$dts_information{$index_name}->{'node_id'}}, $associated_node_id;
      }
    }
  }

  # now construct dts_index and dts_text
  my $dts_index = '';
  my $dts_text = $self->ixin_open_element('dtssets');
  foreach my $index_name (sort(keys(%dts_information))) {
    my $dts_len = 0;
    if (exists($dts_information{$index_name}->{'dts_text'})) {

      $dts_len = $self->_count_bytes($dts_information{$index_name}->{'dts_text'});
      $dts_text .= $dts_information{$index_name}->{'dts_text'};
    }
    my @attributes = ('name',  $index_name, 'dtslen', $dts_len);
    $dts_index .= $self->ixin_open_element('dtsindexentry', \@attributes);
    if ($dts_information{$index_name}->{'node_id'}) {
      foreach my $node_id (sort(@{$dts_information{$index_name}->{'node_id'}})) {
        $dts_index .= $self->ixin_list_element('dtsnodeid', ['nodeid', $node_id]);
        $dts_index .= ' ';
      }
    }
    $dts_index =~ s/ $//;
    $dts_index .= $self->ixin_close_element('dtsindexentry');
  }
  $dts_text .= $self->ixin_close_element('dtssets') ."\n";

  if ($dts_index ne '') {
    $dts_index = $self->ixin_open_element('dtsindex', ['dtsindexlen',
                                         $self->_count_bytes($dts_text)])
         . $dts_index . $self->ixin_close_element('dtsindex');
  } else {
    $dts_index = $self->ixin_none_element('dtsindex')
  }

  # do floats

  my %floats_information;

  # collect all float types corresponding to float commands
  if ($self->{'floats'}) {
    foreach my $type (keys(%{$self->{'floats'}})) {
      $floats_information{$type} = {};
    }
  }

  # collect listoffloats information
  if ($self->{'extra'}->{'listoffloats'}) {
    foreach my $command (@{$self->{'extra'}->{'listoffloats'}}) {
      my $associated_node_id = $self->_associated_node_id($command,
                                                     \%node_label_number);
      my $type = $command->{'extra'}->{'type'}->{'normalized'};
      if ($command->{'extra'}->{'type'}->{'content'}) {
        $floats_information{$type}->{'type'}
          = $self->convert_tree({'contents'
                             => $command->{'extra'}->{'type'}->{'content'}});
      }
      push @{$floats_information{$type}->{'node_id'}}, $associated_node_id;
    }
  }

  # now do the floats sets and the floats index
  my $floats_text = $self->ixin_open_element('floatsset');
  my $floats_index = '';
  foreach my $type (sort(keys(%floats_information))) {
    my $float_text_len = 0;
    if ($self->{'floats'}->{$type}) {
      my $float_nr = 0;
      my $float_text = '';
      foreach my $float (@{$self->{'floats'}->{$type}}) {
        $float_nr++;
        my $associated_node_id;
        # associated node already found when collecting labels
        if (exists($floats_associated_node_id{$float})) {
          $associated_node_id = $floats_associated_node_id{$float};
        } else {
          $associated_node_id = $self->_associated_node_id($float,
                                                     \%node_label_number);
        }
        my @attribute = ('nodeid', $associated_node_id);
        $float_text .= $self->ixin_open_element('floatentry', \@attribute);
        if ($float->{'extra'}->{'normalized'}) {
          $float_text .= $self->ixin_list_element('floatlabel',
                                  ['name', $float->{'extra'}->{'normalized'}]);
          $float_text .= ' ';
        } else {
          $float_text .= $self->ixin_none_element('floatlabel');
        }
        if ($float->{'extra'}->{'node_content'}) {
          $float_text .= $self->ixin_open_element('floatname');
          $float_text .= $self->convert_tree({'contents'
                                 => $float->{'extra'}->{'node_content'}});
          $float_text .= $self->ixin_close_element('floatname');
        } else {
          $float_text .= $self->ixin_none_element('floatname');
        }
        if ($float->{'extra'}->{'shortcaption'}) {
          $float_text .= $self->convert_tree($float->{'extra'}->{'shortcaption'});
        } elsif ($float->{'extra'}->{'caption'}) {
          $float_text .= $self->convert_tree($float->{'extra'}->{'caption'});
        } else {
          $float_text .= $self->ixin_none_element('caption');
        }
        $float_text .= $self->ixin_close_element('floatentry')."\n";
      }
      $float_text = $self->ixin_open_element('floatset', ['count', $float_nr])
              . $float_text .$self->ixin_close_element('floatset')."\n";
      $float_text_len = $self->_count_bytes($float_text);
      $floats_text .= $float_text;

      # determine type expandable string from first float if it was not
      # already determined from listoffloats
      if (!defined($floats_information{$type}->{'type'})) {
        my $command = $self->{'floats'}->{$type}->[0];
        if ($command->{'extra'}->{'type'}
            and $command->{'extra'}->{'type'}->{'content'}) {
          $floats_information{$type}->{'type'}
            = $self->convert_tree({'contents'
                           => $command->{'extra'}->{'type'}->{'content'}});
        }
      }
    }
    my @attribute = ('type', $type, 'floatentrylen', $float_text_len);
    $floats_index .= $self->ixin_open_element('floatindex', \@attribute);
    if ($floats_information{$type}->{'type'}) {
      $floats_index .= $self->ixin_open_element('floatindextype');
      $floats_index .= $floats_information{$type}->{'type'};
      $floats_index .= $self->ixin_close_element('floatindextype');
    } else {
      $floats_index .= $self->ixin_none_element('floatindextype');
    }
    if ($floats_information{$type}->{'node_id'}) {
      foreach my $associated_node_id (@{$floats_information{$type}->{'node_id'}}) {
        $floats_index .= ' ';
        $floats_index .= $self->ixin_list_element('floatindexnode',
                                            ['nodeid', $associated_node_id]);
      }
    }
    $floats_index .= $self->ixin_close_element('floatindex');
  }
  $floats_text .= $self->ixin_close_element('floatsset')."\n";

  if ($floats_index ne '') {
    $floats_index = $self->ixin_open_element('floatsindex', ['floatsindexlen',
                                         $self->_count_bytes($floats_text)])

       .$floats_index .$self->ixin_close_element('floatsindex');
  } else {
    $floats_index = $self->ixin_none_element('floatsindex');
  }

  # do blobs

  my $blobs = '';
  my $blobs_index = '';
  my $blob_nr = 0;
  if ($self->{'extra'}->{'image'}) {
    foreach my $command (@{$self->{'extra'}->{'image'}}) {
      my @extension;
      my $basefile;
      my $extension;
      if (defined($command->{'extra'}->{'brace_command_contents'}->[0])) {
        $basefile = Texinfo::Convert::Text::convert(
          {'contents' => $command->{'extra'}->{'brace_command_contents'}->[0]},
          {'code' => 1, Texinfo::Common::_convert_text_options($self)});
      }
      if (defined($command->{'extra'}->{'brace_command_contents'}->[4])) {
        $extension = Texinfo::Convert::Text::convert(
          {'contents' => $command->{'extra'}->{'brace_command_contents'}->[0]},
          {'code' => 1, Texinfo::Common::_convert_text_options($self)});
        $extension =~ s/^\.//;
        @extension = ($extension);
      }
      foreach my $extension (@extension, @image_files_extensions) {
        my $filename = $basefile.'.'.$extension;
        my $file = $self->Texinfo::Common::locate_include_file($filename);
        if (defined($file)) {
          my $filehandle = do { local *FH };
          if (open ($filehandle, $file)) {
            $blob_nr++;
            if ($extension eq 'txt') {
              binmode($filehandle, ":encoding("
                         .$self->get_conf('INPUT_PERL_ENCODING').")")
                if (defined($self->get_conf('INPUT_PERL_ENCODING')));
            }
            my $file_content;
            if (-z $file) {
              $file_content = '';
            } else {
              $file_content = <$filehandle>;
            }
            my $encoded_file = encode_base64($file_content);
            $blobs .= $encoded_file;
            my $blob_len = $self->_count_bytes($encoded_file);
            my $mime_type;
            if ($extension_mime_mapping{lc($extension)}) {
              $mime_type = $extension_mime_mapping{lc($extension)};
            } else {
              $mime_type = $extension_mime_mapping{''};
            }
            $blobs_index .= $self->ixin_element('blobentry',
             ['bloblen', $blob_len, 'encoding', 'base64',
              'mimetype', $mime_type, 'filename', $filename]) ."\n";
          }
        }
      }
      #print STDERR "$basefile\n";
    }
  }
  $blobs_index = $self->ixin_open_element('blobsindex',
                                            ['count', $blob_nr])
              .$blobs_index.$self->ixin_close_element('blobsindex')."\n";

  my @counts_attributes = ('nodeindexlen', $self->_count_bytes($nodes_index),
                    'nodecounts', $node_nr,
                    'sectioningtreelen', $self->_count_bytes($sectioning_tree),
                    'labelslen', $self->_count_bytes($labels_text),
                    'blobsindexlen', $self->_count_bytes($blobs_index));

  my $output = $self->_output_text($result, $fh);

  my $counts_text = $self->ixin_open_element('counts', \@counts_attributes);
  $counts_text .= $dts_index;
  $counts_text .= $floats_index;
  $counts_text .= $self->ixin_close_element('counts') . "\n";
  $output .= $self->_output_text($counts_text, $fh);

  $output .= $self->_output_text($nodes_index, $fh);
  $output .= $self->_output_text($sectioning_tree, $fh);
  $output .= $self->_output_text($labels_text, $fh);
  $output .= $self->_output_text($dts_text, $fh);
  $output .= $self->_output_text($floats_text, $fh);
  $output .= $self->_output_text($blobs_index, $fh);

  $output .= $self->_output_text($document_output, $fh);
  $output .= $self->_output_text($blobs, $fh);

  if ($fh and $self->{'output_file'} ne '-') {
    $self->register_close_file($self->{'output_file'});
    if (!close ($fh)) {
      $self->document_error(sprintf($self->__("error on closing %s: %s"),
                                    $self->{'output_file'}, $!));
    }
  }
  return $output;
}

1;

repo_name: mthl/texinfo

license: mit


code:
# IXIN.pm: output tree as IXIN with SXML converter.
#
# Copyright 2013 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>
#
# This module implements abstract functions that output the IXIN format
# using lower level formatting funtions, here adapted to lisp like
# output.  For other output, the output specific functions should be
# redefined.  This module is not enough to output IXIN format, a module
# inheriting both from a converter module and this module is required.

package Texinfo::Convert::IXINSXML;

use 5.00405;
use strict;

use Texinfo::Convert::TexinfoSXML;
use Texinfo::Convert::IXIN;

use Carp qw(cluck);

require Exporter;
use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS);
@ISA = qw(Exporter Texinfo::Convert::TexinfoSXML Texinfo::Convert::IXIN);

# 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::Convert::IXIN ':all';
# If you do not need this, moving things directly into @EXPORT or @EXPORT_OK
# will save memory.
%EXPORT_TAGS = ( 'all' => [ qw(
  output
) ] );

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

@EXPORT = qw(
);

$VERSION = '6.3.90';

my %defaults = (
  'ENABLE_ENCODING'      => 0,
  'SHOW_MENU'            => 1,
  'EXTENSION'            => 'ixin',
  #'output_perl_encoding' => 'utf8',
  'OUTPUT_ENCODING_NAME' => 'utf-8',
  # useful?
  'TEXINFO_DTD_VERSION'  => '5.0',
  'OUTFILE'              => undef,
  'SUBDIR'               => undef,
  'output_format'        => 'ixinsxml',
  'SPLIT'                => 0,
  'documentlanguage'     => 'en',
  'USE_NODES'            => 1,
  'GLOBAL_COMMANDS'      => ['image'],
);

sub converter_defaults($$)
{
  return %defaults;
}

sub output($)
{
  my $self = shift;
  my $root = shift;

  return $self->output_ixin($root);
}


code:
# Info.pm: output tree as Info.
#
# Copyright 2010, 2011, 2012, 2013, 2014, 2015, 2016, 2017
# 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>

package Texinfo::Convert::Info;

use 5.00405;
use strict;

use Texinfo::Convert::Plaintext;
use Texinfo::Convert::Text;

use Texinfo::Convert::Paragraph;

require Exporter;
use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS);
@ISA = qw(Texinfo::Convert::Plaintext);

# 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::Convert::Info ':all';
# If you do not need this, moving things directly into @EXPORT or @EXPORT_OK
# will save memory.
%EXPORT_TAGS = ( 'all' => [ qw(
  convert
) ] );

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

@EXPORT = qw(
);

$VERSION = '6.3.90';

my $STDIN_DOCU_NAME = 'stdin';

my %defaults = Texinfo::Convert::Plaintext::converter_defaults(undef, undef);
$defaults{'SHOW_MENU'} = 1;
$defaults{'EXTENSION'} = 'info';
$defaults{'USE_SETFILENAME_EXTENSION'} = 1;
$defaults{'OUTFILE'} = undef;

sub converter_defaults($$)
{
  return %defaults;
}

sub output($)
{
  my $self = shift;
  my $root = shift;

  my $result;

  $self->_set_outfile();
  $self->{'input_basename'} = $STDIN_DOCU_NAME if ($self->{'input_basename'} eq '-');

  # no splitting when writing to the null device or to stdout
  if ($Texinfo::Common::null_device_file{$self->{'output_file'}}
       or $self->{'output_file'} eq '-') {
    $self->force_conf('SPLIT_SIZE', undef);
  }

  push @{$self->{'count_context'}}, {'lines' => 0, 'bytes' => 0,
                                     'locations' => []};
  my $header = $self->_info_header();
  # header + text between setfilename and first node
  my $complete_header = $header;

  pop @{$self->{'count_context'}};
  return undef unless $self->_create_destination_directory();

  my $header_bytes = Texinfo::Convert::Plaintext::count_bytes($self, $header);
  my $complete_header_bytes = $header_bytes;
  my $elements = Texinfo::Structuring::split_by_node($root);

  my $fh;
  if (! $self->{'output_file'} eq '') {
    if ($self->get_conf('VERBOSE')) {
      print STDERR "Output file $self->{'output_file'}\n";
    }
    $fh = _open_info_file($self, $self->{'output_file'});
    if (!$fh) {
      return undef;
    }
  }
  print STDERR "DOCUMENT\n" if ($self->get_conf('DEBUG'));
  my $out_file_nr = 0;
  my @indirect_files;
  if (!defined($elements) or $elements->[0]->{'extra'}->{'no_node'}) {
    $self->file_line_warn($self->__("document without nodes"),
                          $self->{'info'}->{'input_file_name'});
    my $output = $header.$self->_convert($root);
    $self->_count_context_bug_message('no element ');

    my $footnotes = $self->_footnotes();
    $self->_count_context_bug_message('no element footnotes ');

    $output .= $footnotes;
    if ($fh) {
      print $fh $output;
    } else {
      $result = $output;
    }
  } else {
    unless ($self->{'structuring'} and $self->{'structuring'}->{'top_node'}
     and $self->{'structuring'}->{'top_node'}->{'extra'}->{'normalized'} eq 'Top') {
      $self->file_line_warn($self->__("document without Top node"),
                            $self->{'info'}->{'input_file_name'});
    }
    $out_file_nr = 1;
    my $first_node = 0;
    $self->{'count_context'}->[-1]->{'bytes'} += $header_bytes;
    my @nodes = @$elements;
    while (@nodes) {
      my $node = shift @nodes;
      my $node_text = $self->_convert_element($node);
      if (!$first_node) {
        $first_node = 1;
        if (defined($self->{'text_before_first_node'})) {
          $complete_header .= $self->{'text_before_first_node'};
          $complete_header_bytes += Texinfo::Convert::Plaintext::count_bytes($self, $self->{'text_before_first_node'});
        }
        # for the first node, header is prepended, not complete_header
        # as 'text_before_first_node' is already part of the node
        # text
        $node_text = $header . $node_text;
      }
      if ($fh) {
        print $fh $node_text;
      } else {
        $result .= $node_text;
      }
      $self->_update_count_context();
      if (defined($self->get_conf('SPLIT_SIZE'))
          and $self->{'count_context'}->[-1]->{'bytes'} >
                  $out_file_nr * $self->get_conf('SPLIT_SIZE')
          and @nodes and $fh) {
        my $close_error;
        if (!close ($fh)) {
          $close_error = $!;
        }
        if ($out_file_nr == 1) {
          $self->register_close_file($self->{'output_file'});
          if (defined($close_error)) {
            $self->document_error(sprintf($self->__("error on closing %s: %s"),
                                  $self->{'output_file'}, $close_error));
            return undef;
          }
          if ($self->get_conf('VERBOSE')) {
            print STDERR "Renaming first output file as ".
                  $self->{'output_file'}.'-'.$out_file_nr."\n";
          }
          unless (rename($self->{'output_file'},
                         $self->{'output_file'}.'-'.$out_file_nr)) {
            $self->document_error(sprintf($self->__("rename %s failed: %s"),
                                         $self->{'output_file'}, $!));
            return undef;
          }
          # remove the main file from opened files since it was renamed
          # and add the file with a number.
          @{$self->{'opened_files'}} = grep {$_ ne $self->{'output_file'}}
               @{$self->{'opened_files'}};
          push @{$self->{'opened_files'}},
                   $self->{'output_file'}.'-'.$out_file_nr;
          push @indirect_files, [$self->{'output_filename'}.'-'.$out_file_nr,
                                 $complete_header_bytes];
          #print STDERR join(' --> ', @{$indirect_files[-1]}) ."\n";
        } else {
          $self->register_close_file($self->{'output_file'}.'-'.$out_file_nr);
          if (defined($close_error)) {
            $self->document_error(sprintf($self->__("error on closing %s: %s"),
                                  $self->{'output_file'}.'-'.$out_file_nr,
                                  $close_error));
            return undef;
          }
        }
        $out_file_nr++;
        if ($self->get_conf('VERBOSE')) {
          print STDERR "New output file ".
                $self->{'output_file'}.'-'.$out_file_nr."\n";
        }
        $fh = _open_info_file($self, $self->{'output_file'}.'-'.$out_file_nr);
        if (!$fh) {
          return undef;
        }
        print $fh $complete_header;
        $self->_update_count_context();
        $self->{'count_context'}->[-1]->{'bytes'} += $complete_header_bytes;
        push @indirect_files, [$self->{'output_filename'}.'-'.$out_file_nr,
                               $self->{'count_context'}->[-1]->{'bytes'}];
        #print STDERR join(' --> ', @{$indirect_files[-1]}) ."\n";
      }
    }
  }
  my $tag_text = '';
  if ($out_file_nr > 1) {
    $self->register_close_file($self->{'output_file'}.'-'.$out_file_nr);
    if (!close ($fh)) {
      $self->document_error(sprintf($self->__("error on closing %s: %s"),
                            $self->{'output_file'}.'-'.$out_file_nr, $!));
      return undef;
    }
    if ($self->get_conf('VERBOSE')) {
      print STDERR "Outputing the split manual file $self->{'output_file'}\n";
    }
    $fh = _open_info_file($self, $self->{'output_file'});
    if (!$fh) {
      return undef;
    }
    $tag_text = $complete_header;
    $tag_text .= "\x{1F}\nIndirect:";
    foreach my $indirect (@indirect_files) {
      $tag_text .= "\n$indirect->[0]: $indirect->[1]";
    }
  }

  $tag_text .= "\n\x{1F}\nTag Table:\n";
  if ($out_file_nr > 1) {
    $tag_text .=  "(Indirect)\n";
  }
  # This may happen for anchors in @insertcopying
  my %seen_anchors;
  foreach my $label (@{$self->{'count_context'}->[-1]->{'locations'}}) {
    next unless ($label->{'root'} and $label->{'root'}->{'extra'}
                   and defined($label->{'root'}->{'extra'}->{'node_content'}));
    my $prefix;

    if ($label->{'root'}->{'cmdname'} eq 'node') {
      $prefix = 'Node';
    } else {
      $prefix = 'Ref';
    }
    my ($label_text, $byte_count) = $self->_node_line($label->{'root'});

    if ($seen_anchors{$label_text}) {
      $self->line_error(sprintf($self->__("\@%s output more than once: %s"),
          $label->{'root'}->{'cmdname'},
          Texinfo::Convert::Texinfo::convert({'contents' =>
              $label->{'root'}->{'extra'}->{'node_content'}})),
        $label->{'root'}->{'line_nr'});
      next;
    } else {
      $seen_anchors{$label_text} = 1;
    }

    $tag_text .=  "$prefix: $label_text\x{7F}$label->{'bytes'}\n";
  }
  $tag_text .=  "\x{1F}\nEnd Tag Table\n";
  my $coding = $self->get_conf('OUTPUT_ENCODING_NAME');
  if ($coding) {
    $tag_text .= "\n\x{1F}\nLocal Variables:\ncoding: $coding\nEnd:\n";
  }
  if ($fh) {
    print $fh $tag_text;
    # NOTE it should be possible to close STDOUT.  However this leads to
    # 'Filehandle STDOUT reopened as FH only for input' if there are files
    # reopened after closing STDOUT.  So closing STDOUT is handled by the
    # caller.
    unless ($self->{'output_file'} eq '-') {
      $self->register_close_file($self->{'output_file'});
      if (!close ($fh)) {
        $self->document_error(sprintf($self->__("error on closing %s: %s"),
                              $self->{'output_file'}, $!));
      }
    }
  } else {
    $result .= $tag_text;
  }
  return $result;
}

# Wrapper around Texinfo::Common::open_out.  Open the file with any CR-LF
# conversion disabled.  We need this for tag tables to be correct under
# MS-Windows.   Return filehandle or undef on failure.
sub _open_info_file($$)
{
  my $self = shift;
  my $filename = shift;
  my $fh = $self->Texinfo::Common::open_out($filename, undef, 'use_binmode');
  if (!$fh) {
    $self->document_error(sprintf(
        $self->__("could not open %s for writing: %s"),
        $filename, $!));
    return undef;
  }
  return $fh;
}

sub _info_header($)
{
  my $self = shift;

  $self->_set_global_multiple_commands();
  my $paragraph = Texinfo::Convert::Paragraph->new();
  my $result = add_text($paragraph, "This is ");
  # This ensures that spaces in file are kept.
  $result .= add_next($paragraph, $self->{'output_filename'});
  my $program = $self->get_conf('PROGRAM');
  my $version = $self->get_conf('PACKAGE_VERSION');
  if (defined($program) and $program ne '') {
    $result .= add_text($paragraph, ", produced by $program version $version from ");
  } else {
    $result .= add_text($paragraph, ", produced from ");
  }
  $result .= add_next($paragraph, $self->{'input_basename'});
  $result .= add_text($paragraph, '.');
  $result .= Texinfo::Convert::Paragraph::end($paragraph);
  $result .= "\n";
  $self->{'empty_lines_count'} = 1;

  if ($self->{'extra'} and $self->{'extra'}->{'copying'}) {
    print STDERR "COPYING HEADER\n" if ($self->get_conf('DEBUG'));
    $self->{'in_copying_header'} = 1;
    my $copying = $self->_convert({'contents' =>
          $self->{'extra'}->{'copying'}->{'contents'}});
    $result .= $copying;
    $result .= $self->_footnotes();
    delete $self->{'in_copying_header'};
  }
  if ($self->{'info'}->{'dircategory_direntry'}) {
    $self->{'ignored_commands'}->{'direntry'} = 0;
    foreach my $command (@{$self->{'info'}->{'dircategory_direntry'}}) {
      if ($command->{'cmdname'} eq 'dircategory') {
        if ($command->{'extra'}
            and defined($command->{'extra'}->{'misc_content'})) {
          my $dircategory = "INFO-DIR-SECTION ".$self->convert_line(
             {'contents' => $command->{'extra'}->{'misc_content'}});
          $result .= $self->ensure_end_of_line($dircategory);
        }
        $self->{'empty_lines_count'} = 0;
      } elsif ($command->{'cmdname'} eq 'direntry') {
        $result .= "START-INFO-DIR-ENTRY\n";
        my $direntry = $self->_convert($command);
        $result .= $direntry;
        $result .= "END-INFO-DIR-ENTRY\n\n";
        $self->{'empty_lines_count'} = 1;
      }
    }
    $self->{'ignored_commands'}->{'direntry'} = 1;
  }
  $self->_unset_global_multiple_commands();
  return $result;
}

sub _contents($$$)
{
  my $self = shift;
  my $section_root = shift;
  my $contents_or_shortcontents = shift;

  return ('', 0);
}

sub _printindex($$)
{
  my $self = shift;
  my $printindex = shift;
  return $self->_printindex_formatted($printindex, 1);
}

sub _error_outside_of_any_node($$)
{
  my $self = shift;
  my $root = shift;
  if (!$self->{'node'}) {
    $self->line_warn(sprintf($self->__("\@%s outside of any node"),
                     $root->{'cmdname'}), $root->{'line_nr'});
  }
}

my @directions = ('Next', 'Prev', 'Up');
sub _node($$)
{
  my $self = shift;
  my $node = shift;

  my $result = '';
  return '' if (!defined($node->{'extra'}->{'node_content'}));
  if (!$self->{'empty_lines_count'}) {
    $result .= "\n";
    $self->_add_text_count("\n");
    # if in the first node, complete the 'text_before_first_node' too.
    if (!$self->{'first_node_done'}) {
      $self->{'text_before_first_node'} .= "\n";
    }
  }
  if (!$self->{'first_node_done'}) {
    $self->{'first_node_done'} = 1;
  }

  # May happen when only converting a fragment
  my $output_filename = $self->{'output_filename'};
  if (defined($self->{'output_filename'})) {
    $output_filename = $self->{'output_filename'};
  } else {
    $output_filename = '';
  }

  $self->_add_location($node);
  my $node_begin = "\x{1F}\nFile: $output_filename,  Node: ";
  $result .= $node_begin;
  $self->_add_text_count($node_begin);
  my ($node_text, $byte_count) = $self->_node_line($node);
  my $pre_quote = '';
  my $post_quote = '';
  if ($node_text =~ /,/) {
    if ($self->get_conf('INFO_SPECIAL_CHARS_WARNING')) {
      $self->line_warn(sprintf($self->__(
                 "\@node name should not contain `,': %s"), $node_text),
                               $node->{'line_nr'});
    }
    if ($self->get_conf('INFO_SPECIAL_CHARS_QUOTE')) {
      $pre_quote = "\x{7f}";
      $post_quote = $pre_quote;
      $self->{'count_context'}->[-1]->{'bytes'} += 2;
    }
  }
  $self->{'count_context'}->[-1]->{'bytes'} += $byte_count;
  $result .= $pre_quote . $node_text . $post_quote;
  foreach my $direction(@directions) {
    if ($node->{'node_'.lc($direction)}) {
      my $node_direction = $node->{'node_'.lc($direction)};
      my $text = ",  $direction: ";
      $self->_add_text_count($text);
      $result .= $text;
      if ($node_direction->{'extra'}->{'manual_content'}) {
        $result .= $self->convert_line({'type' => '_code',
                          'contents' => [{'text' => '('},
                             @{$node_direction->{'extra'}->{'manual_content'}},
                                          {'text' => ')'}]});
      }
      if ($node_direction->{'extra'}->{'node_content'}) {
        my ($node_text, $byte_count) = $self->_node_line($node_direction);
        $self->{'count_context'}->[-1]->{'bytes'} += $byte_count;
        $result .= $node_text;
      }
    }
  }
  $result .="\n\n";
  $self->_add_text_count("\n\n");
  $self->{'count_context'}->[-1]->{'lines'} = 3;
  $self->{'empty_lines_count'} = 1;

  return $result;
}

my @image_files_extensions = ('.png', '.jpg');
sub _image($$)
{
  my $self = shift;
  my $root = shift;
  my @extensions = @image_files_extensions;

  my $lines_count = 0;

  if (defined($root->{'extra'}->{'brace_command_contents'}->[0])) {
    my $basefile = Texinfo::Convert::Text::convert(
      {'contents' => $root->{'extra'}->{'brace_command_contents'}->[0]},
      {'code' => 1, Texinfo::Common::_convert_text_options($self)});
    if (defined($root->{'extra'}->{'brace_command_contents'}->[4])) {
      my $extension = Texinfo::Convert::Text::convert(
        {'contents' => $root->{'extra'}->{'brace_command_contents'}->[4]},
        {'code' => 1, Texinfo::Common::_convert_text_options($self)});
      unshift @extensions, ".$extension";
      unshift @extensions, "$extension";
    }
    my $image_file;
    foreach my $extension (@extensions) {
      if ($self->Texinfo::Common::locate_include_file ($basefile.$extension)) {
        # use the basename and not the file found.  It is agreed that it is
        # better, since in any case the files are moved.
        $image_file = $basefile.$extension;
        last;
      }
    }
    my ($text, $width) = $self->_image_text($root, $basefile);
    my $alt;
    if (defined($root->{'extra'}->{'brace_command_contents'}->[3])) {
     $alt = Texinfo::Convert::Text::convert(
       {'contents' => $root->{'extra'}->{'brace_command_contents'}->[3]},
       {Texinfo::Common::_convert_text_options($self)});
    }

    my $result;

    if (defined($image_file) or (defined($text) and defined($alt))) {
      $image_file =~ s/\\/\\\\/g;
      $image_file =~ s/\"/\\\"/g;
      $result = "\x{00}\x{08}[image src=\"$image_file\"";

      if (defined($root->{'extra'}->{'brace_command_contents'}->[3])) {
        $alt =~ s/\\/\\\\/g;
        $alt =~ s/\"/\\\"/g;
        $result .= " alt=\"$alt\"";
      }
      if (defined($text)) {
        $text =~ s/\\/\\\\/g;
        $text =~ s/\"/\\\"/g;
        $result .= " text=\"$text\"";
      }
      $result .= "\x{00}\x{08}]";
      if ($self->{'formatters'}->[-1]->{'_top_formatter'}) {
        $result .= "\n";
      }
      my $image_lines_count = ($result =~ tr/\n/\n/) +1;
      $self->_add_image($root, $image_lines_count, $width, 1);
    } else {
      $result = $self->_image_formatted_text($root, $basefile, $text);
      $lines_count = ($result =~ tr/\n/\n/);
      $self->_add_image($root, $lines_count+1, $width);
    }
    return ($result, $lines_count);
  }
  return ('', 0);
}

1;

__END__
# $Id: template.pod 6140 2015-02-22 23:34:38Z karl $
# Automatically generated from maintain/template.pod

=head1 NAME

Texinfo::Convert::Info - Convert Texinfo tree to Info

=head1 SYNOPSIS

  my $converter
    = Texinfo::Convert::Info->converter({'parser' => $parser});

  $converter->output($tree);
  $converter->convert($tree);
  $converter->convert_tree($tree);

=head1 DESCRIPTION

Texinfo::Convert::Info converts a Texinfo tree to Info.

=head1 METHODS

=over

=item $converter = Texinfo::Convert::Info->converter($options)

Initialize converter from Texinfo to Info.

The I<$options> hash reference holds options for the converter.  In
this option hash reference a parser object may be associated with the
I<parser> key.  The other options should be configuration options
described in the Texinfo manual.  Those options, when appropriate,
override the document content.

See L<Texinfo::Convert::Converter> for more informations.

=item $converter->output($tree)

Convert a Texinfo tree I<$tree> and output the result in files as
described in the Texinfo manual.

=item $result = $converter->convert($tree)

Convert a Texinfo tree I<$tree> or tree portion and return
the resulting output.

=item $result = $converter->convert_tree($tree)

Convert a Texinfo tree portion I<$tree> and return the resulting
output.  This function does not try to output a full document but only
portions.  For a full document use C<convert>.

=back

=head1 AUTHOR

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

=head1 COPYRIGHT AND LICENSE

Copyright 2015 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


code:
# Line.pm: handle line of text.
#
# Copyright 2010, 2011, 2012, 2013, 2017 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/>.
#

package Texinfo::Convert::Line;

use 5.006;
use strict;

# initialize a line object.
sub new($;$)
{
  my $class = shift;
  my $conf = shift;

  if (!$conf) {
    $conf = {};
  }

  $conf->{'max'} = 10000001;
  $conf->{'keep_end_lines'} = 1;
  $conf->{'no_final_newline'} = 1;
  $conf->{'add_final_space'} = 1;

  my $paragraph = Texinfo::Convert::Paragraph->new($conf);

  return $paragraph;
}

1;


code:
# NodeNameNormalization.pm: output tree as normalized node name.
#
# Copyright 2010, 2011, 2012, 2016 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>

# the rules for conversion are decribed in the Texinfo manual, for
# HTML crossrefs.

package Texinfo::Convert::NodeNameNormalization;

use 5.00405;
use strict;

use Unicode::Normalize;
use Text::Unidecode;
# for the accents definition
use Texinfo::Common;
# reuse some conversion hashes
use Texinfo::Convert::Text;
# use the hashes and functions
use Texinfo::Convert::Unicode;

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::Convert::NodeNameNormalization ':all';
# If you do not need this, moving things directly into @EXPORT or @EXPORT_OK
# will save memory.
%EXPORT_TAGS = ( 'all' => [ qw(
  normalize_node
  transliterate_texinfo
) ] );

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

@EXPORT = qw(
);

my %normalize_node_brace_no_arg_commands
  = %Texinfo::Convert::Text::text_brace_no_arg_commands;
foreach my $command (keys(%Texinfo::Convert::Unicode::unicode_character_brace_no_arg_commands)) {
  $normalize_node_brace_no_arg_commands{$command} =
     $Texinfo::Convert::Unicode::unicode_character_brace_no_arg_commands{$command};
}

my %normalize_node_no_brace_commands
  = %Texinfo::Common::no_brace_commands;
$normalize_node_no_brace_commands{'*'} = ' ';

my %accent_commands = %Texinfo::Common::accent_commands;

my %ignored_brace_commands;
foreach my $ignored_brace_command ('anchor', 'footnote', 'shortcaption',
                                   'caption', 'hyphenation') {
  $ignored_brace_commands{$ignored_brace_command} = 1;
}

my %ignored_types;
foreach my $type ('empty_line_after_command', 'preamble',
            'empty_spaces_after_command', 'spaces_at_end',
            'empty_spaces_before_argument', 'empty_spaces_before_paragraph',
            'space_at_end_menu_node',
            'empty_spaces_after_close_brace') {
  $ignored_types{$type} = 1;
}

sub normalize_node($)
{
  my $root = shift;
  my $result = convert($root);
  $result = Unicode::Normalize::NFC($result);
  $result = _unicode_to_protected($result);
  $result = 'Top' if ($result =~ /^Top$/i);
  return $result;
}

sub transliterate_texinfo($;$)
{
  my $root = shift;
  my $no_unidecode = shift;
  my $result = convert($root);
  $result = Unicode::Normalize::NFC($result);
  $result = _unicode_to_protected(
                _unicode_to_transliterate($result, $no_unidecode));
  return $result;
}

sub convert($)
{
  my $root = shift;
  my $result = _convert($root);
}

sub _unicode_to_protected($)
{
  my $text = shift;
  my $result = '';
  while ($text ne '') {
    if ($text =~ s/^([A-Za-z0-9]+)//o) {
      $result .= $1;
    } elsif ($text =~ s/^ //o) {
      $result .= '-';
    } elsif ($text =~ s/^(.)//o) {
      my $char = $1;
      if (exists($Texinfo::Convert::Unicode::unicode_simple_character_map{$char})) {
        $result .= '_' . lc($Texinfo::Convert::Unicode::unicode_simple_character_map{$char});
      } else {
        if (ord($char) <= hex(0xFFFF)) {
          $result .= '_' . lc(sprintf("%04x",ord($char)));
        } else {
          $result .= '__' . lc(sprintf("%06x",ord($char)));
        }
      }
    } else {
      warn "Bug: unknown character _unicode_to_protected (likely in infinite loop)\n";
      print STDERR "Text: !!$text!!\n";
      sleep 1;
    }
  }
  return $result;
}

sub _unicode_to_transliterate($;$)
{
  my $text = shift;
  my $no_unidecode = shift;
  if (chomp($text)) {
     warn "Bug: end of line to transliterate: $text\n";
  }
  my $result = '';
  while ($text ne '') {
    if ($text =~ s/^([A-Za-z0-9 ]+)//o) {
      $result .= $1;
    } elsif ($text =~ s/^(.)//o) {
      my $char = $1;
      if (exists($Texinfo::Convert::Unicode::unicode_simple_character_map{$char})) {
        $result .= $char;
      } elsif (ord($char) <= hex(0xFFFF)
               and exists($Texinfo::Convert::Unicode::transliterate_map{uc(sprintf("%04x",ord($char)))})) {
        $result .= $Texinfo::Convert::Unicode::transliterate_map{uc(sprintf("%04x",ord($char)))};
      } elsif (ord($char) <= hex(0xFFFF)
               and exists($Texinfo::Convert::Unicode::diacritics_accent_commands{uc(sprintf("%04x",ord($char)))})) {
        $result .= '';
      # in this case, we want to avoid calling unidecode, as we are sure
      # that there is no useful transliteration of the unicode character
      # instead we want to keep it as is.
      # This is the case, for example, for @exclamdown, is corresponds
      # with x00a1, but unidecode transliterates it to a !, we want
      # to avoid that and keep x00a1.
      } elsif (ord($char) <= hex(0xFFFF)
               and exists($Texinfo::Convert::Unicode::no_transliterate_map{uc(sprintf("%04x",ord($char)))})) {
        $result .= $char;
      } else {
        if ($no_unidecode) {
          if (ord($char) <= hex(0xFFFF)
              and exists ($Texinfo::Convert::Unicode::transliterate_accent_map{uc(sprintf("%04x",ord($char)))})) {
            $result .= $Texinfo::Convert::Unicode::transliterate_accent_map{uc(sprintf("%04x",ord($char)))};
          } else {
            $result .= $char;
          }
        } else {
          $result .= unidecode($char);
        }
      }
      #print STDERR " ($no_unidecode) $text -> CHAR: ".ord($char)." ".uc(sprintf("%04x",ord($char)))."\n$result\n";
    } else {
      warn "Bug: unknown character _unicode_to_transliterate (likely in infinite loop)\n";
      print STDERR "Text: !!$text!!\n";
      sleep 1;
    }
  }
  return $result;
}

sub _convert($;$);

sub _convert($;$)
{
  my $root = shift;
  my $in_sc = shift;

  return '' if (($root->{'type'} and $ignored_types{$root->{'type'}})
          or ($root->{'cmdname'}
             and ($ignored_brace_commands{$root->{'cmdname'}}
             # here ignore the misc commands
                 or ($root->{'args'} and $root->{'args'}->[0]
                     and $root->{'args'}->[0]->{'type'}
                     and ($root->{'args'}->[0]->{'type'} eq 'misc_line_arg'
                         or $root->{'args'}->[0]->{'type'} eq 'misc_arg')))));
  my $result = '';
  if (defined($root->{'text'})) {
    $result = $root->{'text'};
    $result =~ s/\s+/ /go;
    $result = uc($result) if ($in_sc);
  }
  if ($root->{'cmdname'}) {
    my $command = $root->{'cmdname'};
    if (defined($normalize_node_no_brace_commands{$root->{'cmdname'}})) {
      return $normalize_node_no_brace_commands{$root->{'cmdname'}};
    } elsif (defined($normalize_node_brace_no_arg_commands{$root->{'cmdname'}})) {
      $command = $root->{'extra'}->{'clickstyle'}
         if ($root->{'extra'}
          and defined($root->{'extra'}->{'clickstyle'})
          and defined($normalize_node_brace_no_arg_commands{$root->{'extra'}->{'clickstyle'}}));
      my $result = $normalize_node_brace_no_arg_commands{$command};
      if ($in_sc and $Texinfo::Common::letter_no_arg_commands{$command}) {
        $result = uc($result);
      }
      return $result;
    # commands with braces
    } elsif ($accent_commands{$root->{'cmdname'}}) {
      return '' if (!$root->{'args'});
      my $accent_text = _convert($root->{'args'}->[0]);
      my $accented_char
        = Texinfo::Convert::Unicode::unicode_accent($accent_text,
                                                    $root);
      if (!defined($accented_char)) {
        # In this case, the node normalization do not follow the specification,
        # but we cannot do better
        $accented_char = Texinfo::Convert::Text::ascii_accent($accent_text,
                                                              $root);
      }
      if ($in_sc) {
        return uc ($accented_char);
      } else {
        return $accented_char;
      }
    #} elsif ($root->{'cmdname'} eq 'image') {
    #  return _convert($root->{'args'}->[0]);
    } elsif ($Texinfo::Common::ref_commands{$root->{'cmdname'}}) {
      my @args_try_order;
      if ($root->{'cmdname'} eq 'inforef') {
        @args_try_order = (0, 1, 2);
      } else {
        @args_try_order = (0, 1, 2, 4, 3);
      }
      foreach my $index (@args_try_order) {
        if (defined($root->{'args'}->[$index])) {
          my $text = _convert($root->{'args'}->[$index]);
          return $text if (defined($text) and $text =~ /\S/);
        }
      }
      return '';
    # Here all the commands with args are processed, if they have
    # more than one arg the first one is used.
    } elsif ($root->{'args'} and $root->{'args'}->[0]
           and (($root->{'args'}->[0]->{'type'}
                and $root->{'args'}->[0]->{'type'} eq 'brace_command_arg')
                or $root->{'cmdname'} eq 'math')) {
      my $sc = 1 if ($root->{'cmdname'} eq 'sc' or $in_sc);
      return _convert($root->{'args'}->[0], $sc);
    }
  }
  if ($root->{'contents'}) {
    foreach my $content (@{$root->{'contents'}}) {
      $result .= _convert($content, $in_sc);
    }
  }
  $result = '{'.$result.'}'
     if ($root->{'type'} and $root->{'type'} eq 'bracketed');
  return $result;
}

1;

__END__

=head1 NAME

Texinfo::Convert::NodeNameNormalization - Normalize and transliterate Texinfo trees

=head1 SYNOPSIS

  use Texinfo::Convert::NodeNameNormalization qw(normalize_node
                                              transliterate_texinfo);

  my $normalized = normalize_node({'contents' => $node_contents});

  my $file_name = transliterate_texinfo({'contents'
                                            => $section_contents});

=head1 DESCRIPTION

Texinfo::Convert::NodeNameNormalization allows to normalize node names,
with C<normalize_node> following the specification described in the
Texinfo manual for HTML Xref.  This is usefull each time one want a
unique identifier for Texinfo content that is only composed of letter,
digits, C<-> and C<_>.  In C<Texinfo::Parser> C<normalize_node> is used
for node, floats and anchor names normalization, but also float
types C<@acronym> and C<@abbr> first argument.

It is also possible to transliterate non ascii letters, instead of mangling
them, with C<transliterate_texinfo>, losing the uniqueness feature of
normalized node names.

=head1 METHODS

=over

=item $normalized = normalize_node($tree)

The Texinfo I<$tree> is returned as a string, normalized as described in the
Texinfo manual for HTML Xref.

The result will be poor for Texinfo trees which are not @-command arguments
(on an @-command line or in braces), for instance if the tree contains
C<@node> or block commands.

=item $transliterated = transliterate_texinfo($tree, $no_unidecode)

The Texinfo I<$tree> is returned as a string, with non ascii letters
transliterated as ascii, but otherwise similar with C<normalize_node>
output.  If the optional I<$no_unidecode> argument is set, C<Text::Unidecode>
is not used for characters whose transliteration is not built-in.

=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


code:
# Copyright 2014, 2015, 2016 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/>.

package Texinfo::Convert::Paragraph;

# same as texi2any.pl
use 5.00405;
use strict;
use warnings;

our $VERSION = '6.3.90';

use Texinfo::XSLoader;

# Import symbols into the module that is using this one.  We don't
# use the Exporter module because its symbols are lost when we override
# this module with Texinfo::XSLoader::init.
sub import {
  my @EXPORT = qw(
    add_text
    add_next
    set_space_protection
    remove_end_sentence
    allow_end_sentence
    add_end_sentence
    end_line
    add_pending_word
    get_pending
  );

  my ($callpkg, $filename, $line) = caller(0);
  for my $sym (@EXPORT) {
    no strict 'refs';
    *{"${callpkg}::$sym"} = \&{"Texinfo::Convert::Paragraph::${sym}"};
  }
}

BEGIN {
  our $warning_message = undef;
  our $fatal_message = undef;
 # Check for a UTF-8 locale.  Skip the check if the 'locale' command doesn't
 # work.
  our $a;
  if ($^O ne 'MSWin32') {
    $a = `locale -a 2>/dev/null`;
  }
  if ($a and $a !~ /UTF-8/ and $a !~ /utf8/) {
    $fatal_message = "couldn't find a UTF-8 locale";
  }
  if (!$a) {
    $warning_message = "couldn't run 'locale -a': skipping check for a UTF-8 locale";
  }

  # Save reference to subroutine before we do anything.
  my $import_fn = \&import;

  my $package = Texinfo::XSLoader::init (
    "Texinfo::Convert::Paragraph",
    "Texinfo::Convert::XSParagraph::XSParagraph",
    "Texinfo::Convert::ParagraphNonXS",
    "XSParagraph",
    1,
    $warning_message,
    $fatal_message
  );

  no strict 'refs';
  *{"${package}::import"} = $import_fn;
}

# NB Don't add more functions down here, because this can cause an error
# with some versions of Perl, connected with any typeglob assignments done
# above.  ("Can't call mro_method_changed_in() on anonymous symbol table").
#
# See http://perl5.git.perl.org/perl.git/commitdiff/03d9f026ae253e9e69212a3cf6f1944437e9f070?hp=ac73ea1ec401df889d312b067f78b618f7ffecc3
#
# (change to Perl interpreter on 22 Oct 2011)

1;
__END__


code:
# ParagraphNonXS.pm: handle paragraph text.
#
# Copyright 2010, 2011, 2012, 2013, 2014, 2015 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>

# this module has nothing Texinfo specific.  In contrast with existing
# modules Text::Wrap, Text::Format, it keeps a state of the paragraph
# and waits for text to be fed into it.

package Texinfo::Convert::ParagraphNonXS;

use 5.006;
use strict;

use Unicode::EastAsianWidth;
use Carp qw(cluck);

# initialize a paragraph object.
sub new($;$)
{
  my $class = shift;
  my $conf = shift;
  my $self = {'max' => 72, 'indent_length' => 0, 'counter' => 0,
              'word_counter' => 0, 'space' => '', 'frenchspacing' => 0,
              'lines_counter' => 0, 'end_line_count' => 0,
              'unfilled' => 0 };
  if (defined($conf)) {
    foreach my $key (keys(%$conf)) {
      $self->{$key} = $conf->{$key};
    }
  }
  bless $self, $class;
}

# for debugging
sub dump($)
{
  my $self = shift;
  my $word = 'UNDEF';
  if (defined($self->{'word'})) {
    $word = $self->{'word'};
  }
  my $end_sentence = 'UNDEF';
  $end_sentence = $self->{'end_sentence'} if (defined($self->{'end_sentence'}));
  print STDERR "para ($self->{'counter'}+$self->{'word_counter'}) word: $word, space `$self->{'space'}' end_sentence: $end_sentence\n";
}

sub _cut_line($)
{
  my $paragraph = shift;
  return '' if ($paragraph->{'ignore_columns'});
  return _end_line($paragraph);
}

sub end_line_count($)
{
  my $paragraph = shift;
  return $paragraph->{'end_line_count'};
}

sub end_line($)
{
  my $paragraph = shift;
  $paragraph->{'end_line_count'} = 0;
  return _end_line($paragraph);
}

# end a line.
sub _end_line($)
{
  my $paragraph = shift;
  $paragraph->{'counter'} = 0;
  $paragraph->{'space'} = '';
  if (defined($paragraph->{'indent_length_next'})) {
    $paragraph->{'indent_length'} = $paragraph->{'indent_length_next'};
    delete $paragraph->{'indent_length_next'};
  }
  $paragraph->{'lines_counter'}++;
  $paragraph->{'end_line_count'}++;
  print STDERR "END_LINE\n" if ($paragraph->{'DEBUG'});
  return "\n";
}

sub get_pending($)
{
  my $paragraph = shift;
  my $result = '';
  if ($paragraph->{'space'}) {
    $result .= $paragraph->{'space'};
  }
  if (defined($paragraph->{'word'})) {
    $result .= $paragraph->{'word'};
  }
  return $result;
}

sub add_pending_word($;$)
{
  my $paragraph = shift;
  my $add_spaces = shift;
  $paragraph->{'end_line_count'} = 0;
  return _add_pending_word($paragraph, $add_spaces);
}

# put a pending word and spaces in the result string.
sub _add_pending_word($;$)
{
  my $paragraph = shift;
  my $add_spaces = shift;
  my $result = '';

  if (defined($paragraph->{'word'}) or $add_spaces) {
    if ($paragraph->{'indent_length'} > $paragraph->{'counter'}) {
      $result .= ' ' x ($paragraph->{'indent_length'} - $paragraph->{'counter'});
      $paragraph->{'counter'} = $paragraph->{'indent_length'};
      print STDERR "INDENT($paragraph->{'counter'}+$paragraph->{'word_counter'})\n"
                   if ($paragraph->{'DEBUG'});
      delete $paragraph->{'space'} unless $paragraph->{'unfilled'};
    }
    if ($paragraph->{'space'}) {
      $result .= $paragraph->{'space'};
      $paragraph->{'counter'} += length($paragraph->{'space'});
      print STDERR "ADD_SPACES($paragraph->{'counter'}+$paragraph->{'word_counter'})\n"
         if ($paragraph->{'DEBUG'});

    }
    if (defined($paragraph->{'word'})) {
      $result .= $paragraph->{'word'};
      $paragraph->{'counter'} += $paragraph->{'word_counter'};
      print STDERR "ADD_WORD[$paragraph->{'word'}]+$paragraph->{'word_counter'} ($paragraph->{'counter'})\n"
        if ($paragraph->{'DEBUG'});
      $paragraph->{'word'} = undef;
      $paragraph->{'last_char'} = undef;
      $paragraph->{'word_counter'} = 0;
    }
    $paragraph->{'space'} = '';
  }
  return $result;
}

# end a paragraph
sub end($)
{
  my $paragraph = shift;
  $paragraph->{'end_line_count'} = 0;
  print STDERR "PARA END\n" if ($paragraph->{'DEBUG'});
  my $result = _add_pending_word($paragraph, $paragraph->{'add_final_space'});
  if (!$paragraph->{'no_final_newline'} and $paragraph->{'counter'} != 0) {
    $result .= "\n";
    $paragraph->{'lines_counter'}++;
    $paragraph->{'end_line_count'}++;
  }
  return $result;
}

my $end_sentence_character = quotemeta('.?!');
my $after_punctuation_characters = quotemeta('"\')]');

# Add $WORD to paragraph, returning the text to be added to the paragraph.
# Any end of sentence punctuation in $WORD that should be allowed to end a
# sentence but which would otherwise be preceded by an upper-case letter should
# instead by preceded by a backspace character.
sub add_next($;$$)
{
  my $paragraph = shift;
  my $word = shift;
  my $transparent = shift;
  $paragraph->{'end_line_count'} = 0;
  return _add_next($paragraph, $word, $transparent);
}

# add a word (without wrapping).
sub _add_next($;$$$)
{
  my $paragraph = shift;
  my $word = shift;
  my $transparent = shift;
  my $newlines_impossible = shift;
  my $result = '';

  if (defined($word)) {
    my $disinhibit = 0;
    # Reverse the insertion of any control characters in Plaintext.pm.
    if ($word =~ /\x08$/) {
      $disinhibit = 1;
    }
    $word =~ s/\x08//g;

    if (!defined($paragraph->{'word'})) {
      $paragraph->{'word'} = '';
      $paragraph->{'last_char'} = '';
      if ($paragraph->{'end_sentence'}
           and $paragraph->{'end_sentence'} > 0
           and !$paragraph->{'frenchspacing'}
           and $paragraph->{'counter'} != 0 and $paragraph->{'space'}) {
        # do not double space if there are leading spaces in word
        if ($word !~ /^\s/) {
          #$paragraph->{'space'} = '  ';
          $paragraph->{'space'} .= ' ' x (2 - length($paragraph->{'space'}));
        }
        delete $paragraph->{'end_sentence'};
      }
    }

    $paragraph->{'word'} .= $word;

    if (!$transparent) {
      if ($disinhibit) {
        $paragraph->{'last_char'} = 'a';
      } elsif ($word =~
           /([^$end_sentence_character$after_punctuation_characters])
            [$end_sentence_character$after_punctuation_characters]*$/x) {
        # Save the last character in $word before punctuation
        $paragraph->{'last_char'} = $1;
      }
    }

    if (!$newlines_impossible and $word =~ /\n/) {
      $result .= _add_pending_word ($paragraph);
      _end_line($paragraph);
      $paragraph->{'word_counter'} = 0;
      $paragraph->{'word'} = undef;
      $paragraph->{'last_char'} = undef;
    } else {
      my $word2;
      $word2 = $word;
      $word2 =~ s/[\177]//g;
      $paragraph->{'word_counter'} += length($word2);
      # We don't count DEL bytes here for INFO_SPECIAL_CHARS_QUOTE.  We
      # shouldn't count combining characters for accents either: see the
      # t/converters_tests.t (at_commands_in_refs_utf8) test.
    }
    if ($paragraph->{'DEBUG'}) {
      my $para_word = 'UNDEF';;
      if (defined($paragraph->{'word'})) {
        $para_word = $paragraph->{'word'};
      }
      print STDERR "WORD+ $word -> $para_word\n";
    }
    # The $paragraph->{'counter'} != 0 is here to avoid having an
    # additional line output when the text is longer than the max.
    if ($paragraph->{'counter'} != 0 and
        $paragraph->{'counter'} + $paragraph->{'word_counter'} +
           length($paragraph->{'space'}) > $paragraph->{'max'}) {
      $result .= _cut_line($paragraph);
    }
  }
  return $result;
}

sub remove_end_sentence($)
{
  my $paragraph = shift;
  $paragraph->{'end_sentence'} = 0;
}

sub add_end_sentence($;$) {
  my $paragraph = shift;
  my $value = shift;
  $paragraph->{'end_sentence'} = $value;
}

sub allow_end_sentence($)
{
  my $paragraph = shift;
  printf STDERR "ALLOW END SENTENCE\n" if $paragraph->{'DEBUG'};
  $paragraph->{'last_char'} = 'a'; # lower-case
}

sub set_space_protection($$;$$$$)
{
  my $paragraph = shift;
  my $space_protection = shift;
  my $ignore_columns = shift;
  my $keep_end_lines = shift;
  my $frenchspacing = shift;
  my $double_width_no_break = shift;
  $paragraph->{'protect_spaces'} = $space_protection
    if defined($space_protection);
  $paragraph->{'ignore_columns'} = $ignore_columns
    if defined($ignore_columns);
  $paragraph->{'keep_end_lines'} = $keep_end_lines
    if defined($keep_end_lines);
  if (!$paragraph->{'frenchspacing'} and $frenchspacing
    and $paragraph->{'end_sentence'} and $paragraph->{'counter'} != 0
    and $paragraph->{'space'} and !defined($paragraph->{'word'})) {
    $paragraph->{'space'} .= ' ' x (2 - length($paragraph->{'space'}));
    print STDERR "SWITCH frenchspacing end sentence space\n"
       if ($paragraph->{'DEBUG'});
    delete $paragraph->{'end_sentence'};
  }
  $paragraph->{'frenchspacing'} = $frenchspacing
    if defined($frenchspacing);
  $paragraph->{'double_width_no_break'} = $double_width_no_break
    if defined($double_width_no_break);
  # begin a word, to have something even if empty
  if ($space_protection) {
    _add_next($paragraph, '');
  }
  return '';
}

# Wrap $TEXT, returning the wrapped text, taking into account the current state
# of $PARAGRAPH.  Any end of sentence punctuation in $TEXT that should be
# allowed to end a sentence but which would otherwise be preceded by an
# upper-case letter should instead by preceded by a backspace character.
sub add_text($$)
{
  my $paragraph = shift;
  my $text = shift;
  $paragraph->{'end_line_count'} = 0;
  my $result = '';

  my $protect_spaces_flag = $paragraph->{'protect_spaces'};

  my @segments = split
/([^\S\x{202f}\x{00a0}]+)|(\p{InFullwidth})|((?:[^\s\p{InFullwidth}]|[\x{202f}\x{00a0}])+)/,
    $text;

  # Check now if a newline exists anywhere in the string to
  # try to eliminate regex checks later.
  my $newline_possible_flag = ($text =~ /\n/);

  my $debug_flag = $paragraph->{'DEBUG'};
  while (@segments) {
    # $empty_segment should be an empty string; the other variables
    # here were recognized as field separators by splice.
    my ($empty_segment, $spaces, $fullwidth_segment, $added_word)
     = splice (@segments, 0, 4);

    if ($debug_flag) {
      my $word = 'UNDEF';
      $word = $paragraph->{'word'} if (defined($paragraph->{'word'}));
      print STDERR "p ($paragraph->{'counter'}+$paragraph->{'word_counter'}) s `"._print_escaped_spaces($paragraph->{'space'})."', w `$word'\n";
      #print STDERR "TEXT: "._print_escaped_spaces($text)."|\n"
    }
    # \x{202f}\x{00a0} are non breaking spaces
    if (defined $spaces) {
      print STDERR "SPACES($paragraph->{'counter'}) `"._print_escaped_spaces($spaces)."'\n" if $debug_flag;
      if ($protect_spaces_flag) {
        $paragraph->{'word'} .= $spaces;
        $paragraph->{'last_char'} = substr($spaces, -1);
        $paragraph->{'word_counter'} += length($spaces);
        $paragraph->{'word'} =~ s/\n/ /g;

        # The $paragraph->{'counter'} != 0 is here to avoid having an
        # additional line output when the text is longer than the max.
        if ($paragraph->{'counter'} != 0 and
            $paragraph->{'counter'} + $paragraph->{'word_counter'} +
               length($paragraph->{'space'}) > $paragraph->{'max'}) {
          $result .= _cut_line($paragraph);
        }
      } else {
        my $pending_word = $paragraph->{'word'};

        $result .= _add_pending_word($paragraph);
        if ($paragraph->{'counter'} != 0 or $paragraph->{'unfilled'}
            or (defined $pending_word)) {
          if ($paragraph->{'end_sentence'}
              and $paragraph->{'end_sentence'} > 0
              and !$paragraph->{'frenchspacing'}
              and !$paragraph->{'unfilled'}) {
            if (length($paragraph->{'space'}) >= 1 or length($spaces) > 1) {
              # more than one space, we can make sure tht there are only
              # 2 spaces
              my $all_spaces = substr($paragraph->{'space'} . $spaces, 0, 2);
              $all_spaces =~ s/[\n\r]/ /g;
              $all_spaces .= ' ' x (2 - length($all_spaces));
              $paragraph->{'space'} = $all_spaces;
            } else {
              # if there is only one space, we let it accumulate
              my $new_space = $spaces;
              $new_space =~ s/^[\n\r]/ /;
              $paragraph->{'space'} = $new_space;
            }
          } else {
            # Only save the first space
            if ($paragraph->{'unfilled'}
                or length($paragraph->{'space'}) < 1) {
              if ($spaces =~ /\n/) {
                if (!$paragraph->{'unfilled'}) {
                  $paragraph->{'space'} = ' ';
                } elsif ($spaces =~ /\n/) {
                  $result .= _add_pending_word ($paragraph);
                  $result .= _end_line ($paragraph);
                }
              } else {
                if (!$paragraph->{'unfilled'}) {
                  $spaces =~ s/\r/ /g;
                  $paragraph->{'space'} .= substr ($spaces, 0, 1);
                } else {
                  $paragraph->{'space'} .= $spaces;
                }
              }
            }
          }
        }
      }
      #print STDERR "delete END_SENTENCE($paragraph->{'end_sentence'}): spaces\n"
      #  if (defined($paragraph->{'end_sentence'}) and $paragraph->{'DEBUG'});
      #delete $paragraph->{'end_sentence'};
      if ($paragraph->{'counter'} + length($paragraph->{'space'})
                      > $paragraph->{'max'}) {
        $result .= _cut_line($paragraph);
      }
      if ($newline_possible_flag and !$paragraph->{'unfilled'}
          and $paragraph->{'keep_end_lines'} and $spaces =~ /\n/) {
        $result .= _end_line($paragraph);
      }
    } elsif (defined $added_word) {
      my $tmp = $added_word;
      if (defined $paragraph->{'last_char'}) {
        # Use 'last_char' here because _add_next overwrites it.
        $tmp = $paragraph->{'last_char'} . $tmp;
      }

      $result .= _add_next($paragraph, $added_word, undef,
                           !$newline_possible_flag);

      # Check if it is considered as an end of sentence.  There are two things
      # to check: one, that we have a ., ! or ?; and second, that it is not
      # preceded by an upper-case letter (ignoring some punctuation)
      if (defined($paragraph->{'end_sentence'})
          and $added_word =~ /^[$after_punctuation_characters]*$/o) {
        # do nothing in the case of a continuation of after_punctuation_characters
      } elsif (!$paragraph->{'unfilled'}
          and $tmp =~
        /(^|[^[:upper:]$after_punctuation_characters$end_sentence_character])
         [$after_punctuation_characters]*[$end_sentence_character]
         [$end_sentence_character\x08$after_punctuation_characters]*$/x) {
        if ($paragraph->{'frenchspacing'}) {
          $paragraph->{'end_sentence'} = -1;
        } else {
          $paragraph->{'end_sentence'} = 1;
        }
        print STDERR "END_SENTENCE\n" if ($paragraph->{'DEBUG'});
      } else {
        delete $paragraph->{'end_sentence'};
        print STDERR "delete END_SENTENCE($paragraph->{'end_sentence'}): text\n"
          if (defined($paragraph->{'end_sentence'}) and $paragraph->{'DEBUG'});
      }
    } elsif (defined $fullwidth_segment) {
      print STDERR "EAST_ASIAN\n" if ($paragraph->{'DEBUG'});
      if (!defined($paragraph->{'word'})) {
        $paragraph->{'word'} = '';
      }
      $paragraph->{'word'} .= $fullwidth_segment;
      $paragraph->{'last_char'} = $fullwidth_segment;
      $paragraph->{'word_counter'} += 2;
      if ($paragraph->{'counter'} != 0 and
          $paragraph->{'counter'} + $paragraph->{'word_counter'}
                               > $paragraph->{'max'}) {
        $result .= _cut_line($paragraph);
      }
      if (!$paragraph->{'protect_spaces'}
          and !$paragraph->{'double_width_no_break'}) {
        $result .= _add_pending_word($paragraph);
        $paragraph->{'space'} = '';
      }
      delete $paragraph->{'end_sentence'};
    }
  }
  return $result;
}

# for debug
sub _print_escaped_spaces($)
{
  my $spaces = shift;
  my $result = '';
  foreach my $pos (0 .. length($spaces)-1) {
    my $char = substr($spaces, $pos, 1);
    if ($char eq ' ') {
      $result .= $char;
    } elsif ($char =~ /[\f\n]/) {
      $char =~ s/\f/\\f/;
      $char =~ s/\n/\\n/;
      $result .= $char;
    } elsif ($char =~ /\s/) {
      if (ord($char) <= hex(0xFFFF)) {
        $result .= '\x'.sprintf("%04x",ord($char));
      } else {
        $result .= '\x'.sprintf("%06x",ord($char));
      }
    } else {
      $result .= $char;
    }
  }
  return $result;
}

1;


code:
# PlainTexinfo.pm: convert the Texinfo tree as Texinfo
#
# Copyright 2012 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>

# This calls Texinfo::Convert::Texinfo::convert while inheriting standard
# functions from Texinfo::Convert::Converter.

package Texinfo::Convert::PlainTexinfo;

use 5.00405;
use strict;

use Texinfo::Convert::Converter;

use vars qw($VERSION @ISA);
@ISA = qw(Texinfo::Convert::Converter);

my %defaults = (
  'OUTFILE'              => '-',
  'EXTENSION'            => '.txi',
);

sub converter_defaults($$)
{
  return %defaults;
}

sub convert_tree($$)
{
  my $self = shift;
  my $root = shift;

  return $self->_convert($root);
}

sub convert($$)
{
  my $self = shift;
  my $root = shift;

  return $self->_convert($root);
}

sub _convert($$);

sub _convert($$)
{
  my $self = shift;
  my $root = shift;

  return Texinfo::Convert::Texinfo::convert($root,
                                            $self->get_conf('FIX_TEXINFO'));
}

1;