# t/* test support for the Perl modules.
#
# Copyright 2010-2023 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 .
#
# Original author: Patrice Dumas
use strict;
#no autovivification qw(fetch delete exists store strict);
use 5.006;
BEGIN {
require Texinfo::ModulePath;
Texinfo::ModulePath::init(undef, undef, undef, 'updirs' => 2);
# NOTE in general file names and directory names are not encoded,
# there will be problems if there are non ascii characters in those
# strings.
# For consistent test results, use the C locale.
# Note that this could prevent displaying non ascii characters
# in error messages.
$ENV{LC_ALL} = 'C';
$ENV{LANGUAGE} = 'en';
} # end BEGIN
use Test::More;
# to determine the locale encoding to output the Texinfo to Texinfo
# result when regenerating
use I18N::Langinfo qw(langinfo CODESET);
use Encode ();
#use File::Basename;
#use File::Copy;
use File::Compare qw(compare); # standard since 5.004
use Data::Dumper ();
use Data::Compare ();
use Test::Deep ();
use Storable qw(dclone); # standard in 5.007003
#use Data::Diff;
#use Data::Transformer;
#use Struct::Compare;
use Getopt::Long qw(GetOptions);
use Locale::Messages ();
use Texinfo::Commands;
use Texinfo::Common;
use Texinfo::Convert::Texinfo;
use Texinfo::Config;
use Texinfo::Parser;
use Texinfo::Convert::Text;
use Texinfo::Structuring;
use Texinfo::Convert::Plaintext;
use Texinfo::Convert::Info;
use Texinfo::Convert::LaTeX;
use Texinfo::Convert::HTML;
use Texinfo::Convert::TexinfoXML;
use Texinfo::Convert::DocBook;
# the tests reference perl results file is loaded through a require
# with those variables.
use vars qw(%result_texis %result_texts %result_trees %result_errors
%result_indices %result_sectioning %result_nodes %result_menus
%result_floats %result_converted %result_converted_errors
%result_elements %result_directions_text %result_indices_sort_strings);
my $strings_textdomain = 'texinfo_document';
Locale::Messages->select_package('gettext_pp');
my $srcdir = $ENV{'srcdir'};
my $locales_srcdir;
if (defined($srcdir)) {
$srcdir =~ s/\/*$/\//;
$locales_srcdir = $srcdir;
} else {
$srcdir = '';
$locales_srcdir = '.';
}
my $localesdir;
foreach my $dir ("LocaleData", "$locales_srcdir/LocaleData") {
if (-d $dir) {
$localesdir = $dir;
}
}
if (! defined($localesdir)) {
warn "No locales directory found, some tests will fail\n";
}
Locale::Messages::bindtextdomain('texinfo_document', $localesdir);
Locale::Messages::bindtextdomain('texinfo', $localesdir);
my $generated_texis_dir = 't_texis';
my $input_files_dir = $srcdir."t/input_files/";
my $output_files_dir = 't/output_files/';
foreach my $dir ('t', 't/results', $output_files_dir) {
my $error;
# to avoid a race conditon, first create the dir then test that it
# exists
mkdir $dir or $error = $!;
if (! -d $dir) {
die "mkdir $dir: $error\n";
}
}
my $locale_encoding = langinfo(CODESET);
$locale_encoding = undef if ($locale_encoding eq '');
# to encode is() diagnostic messages. From Test::More documentation
if (defined($locale_encoding)) {
my $builder = Test::More->builder;
binmode $builder->output, ":encoding($locale_encoding)";
binmode $builder->failure_output, ":encoding($locale_encoding)";
binmode $builder->todo_output, ":encoding($locale_encoding)";
}
# used to check that there are no file overwritten with -o
my %output_files;
ok(1);
my %formats = (
'plaintext' => \&convert_to_plaintext,
'file_plaintext' => \&convert_to_plaintext,
'info' => \&convert_to_info,
'file_info' => \&convert_to_info,
'html' => \&convert_to_html,
'file_html' => \&convert_to_html,
'html_text' => \&convert_to_html,
'xml' => \&convert_to_xml,
'file_xml' => \&convert_to_xml,
'docbook' => \&convert_to_docbook,
'file_docbook' => \&convert_to_docbook,
'docbook_doc' => \&convert_to_docbook,
'latex' => \&convert_to_latex,
'latex_text' => \&convert_to_latex,
'file_latex' => \&convert_to_latex,
);
my %extensions = (
'plaintext' => 'txt',
'html_text' => 'html',
'xml' => 'xml',
'docbook' => 'dbk',
'docbook_doc' => 'dbk',
'latex' => 'tex',
'latex_text' => 'tex',
);
# This is, in general, different from the documented version, which
# is set in the texi2any main program. This value should only be
# used in t/*.t tests.
my $XML_DTD_VERSION
= $Texinfo::Common::default_converter_customization{'TEXINFO_DTD_VERSION'};
my %outfile_preamble = (
'docbook' => ['
]>
'. "\n", "\n"],
'xml' => ['
'."
".'
', "\n"],
# done dynamically for CSS
'html_text' => \&output_preamble_postamble_html,
'latex_text' => \&output_preamble_postamble_latex,
);
my $arg_generate;
my $arg_debug;
my $arg_complete;
my $arg_output;
my $nr_comparisons = 9;
Getopt::Long::Configure("gnu_getopt");
# complete: output a complete texinfo file based on the test. Does not
# run the tests at all.
# generate: run the tests and reset reference results instead of comparing
# with reference results.
# output: run the test, compare with references, and output the test results
# (even if not the same as references) in output files per output
# format.
GetOptions('g|generate' => \$arg_generate, 'd|debug=i' => \$arg_debug,
'c|complete' => \$arg_complete, 'o|output' => \$arg_output);
sub protect_perl_string($)
{
my $string = shift;
$string =~ s/\\/\\\\/g;
$string =~ s/'/\\'/g;
# \r can be mangled upon reading if at end of line
$string =~ s/\r/'."\\r".'/g;
return $string;
}
# remove the association with document units
sub unsplit($)
{
my $root = shift;
if (!$root->{'type'} or $root->{'type'} ne 'document_root'
or !$root->{'contents'}) {
return;
}
my $unsplit_needed = 0;
foreach my $content (@{$root->{'contents'}}) {
if ($content->{'structure'}) {
if ($content->{'structure'}->{'associated_unit'}) {
delete $content->{'structure'}->{'associated_unit'};
$unsplit_needed = 1;
}
if (scalar(keys(%{$content->{'structure'}})) == 0) {
delete $content->{'structure'};
}
}
}
return $unsplit_needed;
}
sub compare_dirs_files($$;$)
{
my $dir1 = shift;
my $dir2 = shift;
my $ignore_files = shift;
my %dir1_files;
my %dir2_files;
my @errors;
my %ignored_files_hash;
foreach my $ignored_file (@$ignore_files) {
$ignored_files_hash{$ignored_file} = 1;
}
if (opendir(DIR1, $dir1)) {
my @files = readdir (DIR1);
foreach my $file (@files) {
next if (! -r "$dir1/$file" or ! -f "$dir1/$file"
or $ignored_files_hash{$file});
$dir1_files{$file} = 1;
}
closedir (DIR1);
} else {
push @errors, "readdir $dir1: $!";
}
if (opendir(DIR2, $dir2)) {
my @files = readdir (DIR2);
foreach my $file (@files) {
next if (! -r "$dir2/$file" or ! -f "$dir2/$file"
or $ignored_files_hash{$file});
$dir2_files{$file} = 1;
}
closedir (DIR2);
} else {
push @errors, "readdir $dir2: $!";
}
if (scalar(@errors)) {
return \@errors;
}
foreach my $file (sort(keys(%dir1_files))) {
if ($dir2_files{$file}) {
my $status = compare("$dir1/$file", "$dir2/$file");
if ($status) {
push @errors, "$dir1/$file and $dir2/$file differ: $status";
}
delete $dir2_files{$file};
} else {
push @errors, "No $file in $dir2";
}
}
foreach my $file (sort(keys(%dir2_files))) {
push @errors, "No $file in $dir1"
}
if (scalar(@errors)) {
return \@errors;
} else {
return undef;
}
}
#my $errors = compare_dirs_files('a', 'b',['nnn']);
#if ($errors) {
# foreach my $error (@$errors) {
# warn $error."\n";
# }
#}
sub unlink_dir_files($;$)
{
my $dir = shift;
my $ignore_files = shift;
my %ignored_files_hash;
foreach my $ignored_file (@$ignore_files) {
$ignored_files_hash{$ignored_file} = 1;
}
if (opendir(DIR, $dir)) {
my @files = readdir (DIR);
foreach my $file (@files) {
next if (! -f "$dir/$file"
or $ignored_files_hash{$file});
unlink "$dir/$file" or warn "Could not unlink $dir/$file: $!\n";
}
closedir (DIR);
} else {
warn "readdir $dir: $!";
}
}
#my $remove_parent = sub {my $h = shift; delete $h->{'parent'}};
#my $transformer = Data::Transformer->new('hash'=>$remove_parent);
sub remove_keys($$;$);
sub remove_keys($$;$)
{
my $root = shift;
my $deleted_keys = shift;
my $been_there = shift;
return undef if (!defined($root));
if (!defined($been_there)) {
#print STDERR "First call: $root\n";
$root = dclone($root);
#print STDERR Data::Dumper->Dump([$root]);
$been_there = {};
}
#print STDERR "remove_keys: $root\n";
if (ref($root) eq 'HASH') {
foreach my $key (@$deleted_keys) {
if (exists($root->{$key})) {
delete ($root->{$key});
#print STDERR "Deleted $root $key\n";
}
}
$been_there->{$root} = 1;
foreach my $key (keys(%$root)) {
next if (!defined($root->{$key}) or !ref($root->{$key})
or (ref($root->{$key}) ne 'HASH'
and ref($root->{$key}) ne 'ARRAY')
or exists($been_there->{$root->{$key}}));
#print STDERR "Recurse in $root $key\n";
remove_keys($root->{$key}, $deleted_keys, $been_there);
}
} elsif (ref($root) eq 'ARRAY') {
$been_there->{$root} = 1;
foreach my $element (@$root) {
next if (!defined($element) or !ref($element)
or (ref($element) ne 'HASH'
and ref($element) ne 'ARRAY')
or exists($been_there->{$element}));
remove_keys($element, $deleted_keys, $been_there);
}
}
return $root;
}
# currently unused, but could be used again.
sub duplicate_key_array($$)
{
my $element = shift;
my $key = shift;
if (defined($element) and exists($element->{$key})
and defined($element->{$key})) {
my $new_content = [];
foreach my $array_item (@{$element->{$key}}) {
push @$new_content, $array_item;
}
$element->{$key} = $new_content;
}
}
# used to have a similar output as the XS parser
# when using the pure perl parser.
sub _duplicate_element_keys($$)
{
my $type = shift;
my $current = shift;
if (exists($current->{'source_info'})) {
# cannot use dclone as dclone changes integers to strings
#$current->{'source_info'} = dclone($current->{'source_info'});
my $new_source_info = {};
foreach my $key(keys(%{$current->{'source_info'}})) {
$new_source_info->{$key} = $current->{'source_info'}->{$key};
}
$current->{'source_info'} = $new_source_info;
}
return ($current);
}
sub duplicate_tree_element_keys($)
{
my $tree = shift;
return Texinfo::Common::modify_tree($tree, \&_duplicate_element_keys);
}
sub cmp_trimmed($$$$)
{
my $compared = shift;
my $reference = shift;
my $deleted_keys = shift;
my $test_name = shift;
my $trimmed = remove_keys($compared, $deleted_keys);
no warnings 'recursion';
Test::Deep::cmp_deeply($trimmed, $reference, $test_name);
}
sub new_test($;$$$)
{
my $name = shift;
my $generate = shift;
my $debug = shift;
my $test_formats = shift;
my $test = {'name' => $name, 'generate' => $generate,
'DEBUG' => $debug, 'test_formats' => $test_formats};
if ($generate) {
mkdir $srcdir."t/results/$name" if (! -d $srcdir."t/results/$name");
}
bless $test;
return $test;
}
# keys under 'info' are not needed here.
my @contents_keys = ('contents', 'args', 'parent', 'source_info',
'node_content', 'invalid_nesting', 'info', 'text_arg',
'node_description', 'node_long_description');
my @menus_keys = ('menu_next', 'menu_up', 'menu_prev', 'menu_up_hash');
# 'section_number' is kept in other results as it may be the only clue
# to know which section element it is.
my @sections_keys = ('section_next', 'section_prev', 'section_up',
'section_childs', 'associated_node', 'part_associated_section',
'part_following_node', 'section_level',
'toplevel_prev', 'toplevel_next', 'toplevel_up');
my @node_keys = ('node_next', 'node_prev', 'node_up', 'menus',
'associated_section', 'node_preceding_part');
# in general, the 'parent' keys adds lot of non legible information,
# however to punctually test for regressions on this information, the
# best is to add it in tree tests by removing from @avoided_keys_tree.
my %avoided_keys_tree;
my @avoided_keys_tree = (@sections_keys, @menus_keys, @node_keys,
# FIXME remaining_args should not be present in the final tree, but they are
'remaining_args',
'structure', 'menu_child', 'unit_next', 'directions', 'page_next',
'parent');
foreach my $avoided_key(@avoided_keys_tree) {
$avoided_keys_tree{$avoided_key} = 1;
}
sub filter_tree_keys { [grep {!$avoided_keys_tree{$_}} ( sort keys %{$_[0]} )] }
my %avoided_keys_sectioning;
my @avoided_keys_sectioning = ('section_next', @contents_keys, @menus_keys,
@node_keys, 'menu_child', 'manual_content', 'toplevel_next');
foreach my $avoided_key(@avoided_keys_sectioning) {
$avoided_keys_sectioning{$avoided_key} = 1;
}
sub filter_sectioning_keys { [grep {!$avoided_keys_sectioning{$_}}
( sort keys %{$_[0]} )] }
my %avoided_keys_nodes;
my @avoided_keys_nodes = (@sections_keys, @contents_keys, @menus_keys);
foreach my $avoided_key(@avoided_keys_nodes) {
$avoided_keys_nodes{$avoided_key} = 1;
}
sub filter_nodes_keys { [grep {!$avoided_keys_nodes{$_}}
( sort keys %{$_[0]} )] }
my %avoided_keys_menus;
my @avoided_keys_menus = (@sections_keys, @contents_keys, @node_keys);
foreach my $avoided_key(@avoided_keys_menus) {
$avoided_keys_menus{$avoided_key} = 1;
}
sub filter_menus_keys { [grep {!$avoided_keys_menus{$_}}
( sort keys %{$_[0]} )] }
my %avoided_keys_floats;
my @avoided_keys_floats = (@sections_keys, @contents_keys, @node_keys,
@menus_keys);
foreach my $avoided_key(@avoided_keys_floats) {
$avoided_keys_floats{$avoided_key} = 1;
}
sub filter_floats_keys { [grep {!$avoided_keys_floats{$_}}
( sort keys %{$_[0]} )] }
my %avoided_keys_elements;
my @avoided_keys_elements = (@contents_keys, @sections_keys, @node_keys,
'unit_next', 'unit_prev');
foreach my $avoided_key(@avoided_keys_elements) {
$avoided_keys_elements{$avoided_key} = 1;
}
sub filter_elements_keys {[grep {!$avoided_keys_elements{$_}}
( sort keys %{$_[0]} )] }
sub set_converter_option_defaults($$$)
{
my $converter_options = shift;
my $main_configuration = shift;
my $format = shift;
$converter_options = {} if (!defined($converter_options));
if (!defined($converter_options->{'EXPANDED_FORMATS'})) {
$converter_options->{'EXPANDED_FORMATS'} = [$format];
}
if (!defined($converter_options->{'output_format'})) {
$converter_options->{'output_format'} = $format;
}
return $converter_options;
}
sub close_files($)
{
my $converter = shift;
my $converter_unclosed_files
= Texinfo::Common::output_files_unclosed_files(
$converter->output_files_information());
if ($converter_unclosed_files) {
foreach my $unclosed_file (keys(%$converter_unclosed_files)) {
if (!close($converter_unclosed_files->{$unclosed_file})) {
# FIXME or die?
warn(sprintf("tp_utils.pl: error on closing %s: %s\n",
$converter_unclosed_files->{$unclosed_file}, $!));
}
}
}
}
sub convert_to_plaintext($$$$$$;$)
{
my $self = shift;
my $test_name = shift;
my $format = shift;
my $tree = shift;
my $parser = shift;
my $main_configuration = shift;
my $converter_options = shift;
$converter_options
= set_converter_option_defaults($converter_options,
$main_configuration, $format);
if (!defined($converter_options->{'OUTFILE'})
and defined($converter_options->{'SUBDIR'})) {
# need to set OUTFILE in any case otherwise the default of -
# will be used
if ($converter_options->{'SPLIT'}) {
$converter_options->{'OUTFILE'} = undef;
} else {
$converter_options->{'OUTFILE'}
= $converter_options->{'SUBDIR'}.$test_name.".txt";
}
}
my $converter =
Texinfo::Convert::Plaintext->converter({'DEBUG' => $self->{'DEBUG'},
'parser' => $parser,
'converted_format' => 'plaintext',
%$converter_options });
my $result;
if (defined($converter_options->{'OUTFILE'})
and $converter_options->{'OUTFILE'} eq '') {
$result = $converter->convert($tree);
} else {
$result = $converter->output($tree);
close_files($converter);
$result = undef if (defined($result) and ($result eq ''));
}
my ($errors, $error_nrs) = $converter->errors();
return ($errors, $result, $converter);
}
sub convert_to_info($$$$$;$)
{
my $self = shift;
my $test_name = shift;
my $format = shift;
my $tree = shift;
my $parser = shift;
my $main_configuration = shift;
my $converter_options = shift;
# FIXME plaintext too?
$converter_options
= set_converter_option_defaults($converter_options,
$main_configuration, $format);
my $converter =
Texinfo::Convert::Info->converter ({'DEBUG' => $self->{'DEBUG'},
'parser' => $parser,
'converted_format' => 'info',
%$converter_options });
my $result = $converter->output($tree);
close_files($converter);
die if (!defined($converter_options->{'SUBDIR'}) and !defined($result));
my ($errors, $error_nrs) = $converter->errors();
return ($errors, $result, $converter);
}
sub convert_to_html($$$$$$;$)
{
my $self = shift;
my $test_name = shift;
my $format = shift;
my $tree = shift;
my $parser = shift;
my $main_configuration = shift;
my $converter_options = shift;
$converter_options
= set_converter_option_defaults($converter_options,
$main_configuration, 'html');
$converter_options->{'SPLIT'} = 0
if ($format eq 'html_text'
and !defined($converter_options->{'SPLIT'}));
my $converter =
Texinfo::Convert::HTML->converter ({'DEBUG' => $self->{'DEBUG'},
'parser' => $parser,
'converted_format' => 'html',
%$converter_options });
my $result;
if ($format eq 'html_text') {
$result = $converter->convert($tree);
} else {
$result = $converter->output($tree);
close_files($converter);
}
die if (!defined($converter_options->{'SUBDIR'}) and !defined($result));
my ($errors, $error_nrs) = $converter->errors();
return ($errors, $result, $converter);
}
sub convert_to_xml($$$$$$;$)
{
my $self = shift;
my $test_name = shift;
my $format = shift;
my $tree = shift;
my $parser = shift;
my $main_configuration = shift;
my $converter_options = shift;
$converter_options
= set_converter_option_defaults($converter_options,
$main_configuration, 'xml');
my $converter =
Texinfo::Convert::TexinfoXML->converter ({'DEBUG' => $self->{'DEBUG'},
'parser' => $parser,
'converted_format' => 'texinfoxml',
%$converter_options });
my $result;
if (defined($converter_options->{'OUTFILE'})
and $converter_options->{'OUTFILE'} eq '') {
$result = $converter->convert($tree);
} else {
$result = $converter->output($tree);
close_files($converter);
$result = undef if (defined($result) and ($result eq ''));
}
my ($errors, $error_nrs) = $converter->errors();
return ($errors, $result, $converter);
}
sub convert_to_docbook($$$$$$;$)
{
my $self = shift;
my $test_name = shift;
my $format = shift;
my $tree = shift;
my $parser = shift;
my $main_configuration = shift;
my $converter_options = shift;
$converter_options
= set_converter_option_defaults($converter_options,
$main_configuration, 'docbook');
my $converter =
Texinfo::Convert::DocBook->converter ({'DEBUG' => $self->{'DEBUG'},
'parser' => $parser,
'converted_format' => 'docbook',
%$converter_options });
my $result;
my $tree_for_conversion;
# 'before_node_section' is ignored in conversion to DocBook and it is
# the type, in 'document_root' that holds content that appear out of any
# @node and sectioning command. To be able to have tests of simple
# Texinfo code out of any sectioning or @node command with DocBook,
# a tree consisting in a sole 'before_node_section' is duplicated
# as a tree with an element without type replacing the 'before_node_section'
# type element, with the same contents.
if ($tree->{'contents'} and scalar(@{$tree->{'contents'}}) == 1) {
$tree_for_conversion = {
'type' => $tree->{'type'},
'contents' => [{'contents' => $tree->{'contents'}->[0]->{'contents'}}]
}
} else {
$tree_for_conversion = $tree;
}
if (defined($converter_options->{'OUTFILE'})
and $converter_options->{'OUTFILE'} eq ''
and $format ne 'docbook_doc') {
$result = $converter->convert($tree_for_conversion);
} else {
$result = $converter->output($tree_for_conversion);
close_files($converter);
$result = undef if (defined($result) and ($result eq ''));
}
my ($errors, $error_nrs) = $converter->errors();
return ($errors, $result, $converter);
}
sub convert_to_latex($$$$$$;$)
{
my $self = shift;
my $test_name = shift;
my $format = shift;
my $tree = shift;
my $parser = shift;
my $main_configuration = shift;
my $converter_options = shift;
$converter_options
= set_converter_option_defaults($converter_options,
$main_configuration, 'latex');
my $converter =
Texinfo::Convert::LaTeX->converter ({'DEBUG' => $self->{'DEBUG'},
'parser' => $parser,
'converted_format' => 'latex',
%$converter_options });
my $result;
if ($format eq 'latex_text') {
$result = $converter->convert($tree);
} else {
$result = $converter->output($tree);
close_files($converter);
$result = undef if (defined($result) and ($result eq ''));
}
my ($errors, $error_nrs) = $converter->errors();
return ($errors, $result, $converter);
}
sub output_preamble_postamble_html($$)
{
my $converter = shift;
my $postamble = shift;
if ($postamble) {
return '