# 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 ' ' } else { my $encoding = ''; $encoding = "\n" if (defined($converter->get_conf('OUTPUT_ENCODING_NAME')) and ($converter->get_conf('OUTPUT_ENCODING_NAME') ne '')); return ' Untitled Document '.$encoding .&{$converter->formatting_function('format_css_lines')}($converter, $converter->{'current_filename'}) .' '; } } sub output_preamble_postamble_latex($$) { my $converter = shift; my $postamble = shift; my $parser_options = shift; if ($postamble) { return '\end{document} '; } else { my $begin_document = '\begin{document} '; if ($parser_options and $parser_options->{'full_document'}) { $begin_document = ''; } return $converter->_latex_header() . $begin_document; } } # Run a single test case. Each test case is an array # [TEST_NAME, TEST_TEXT, PARSER_OPTIONS, CONVERTER_OPTIONS] sub test($$) { my $self = shift; my $test_case = shift; my $parser_options = {}; my $converter_options = undef; my ($test_name, $test_text); my $tests_count = 0; $test_name = shift @$test_case; die if (!defined($test_name)); $test_text = shift @$test_case; $parser_options = shift @$test_case if (@$test_case); $converter_options = shift @$test_case if (@$test_case); $converter_options = {} if (! defined($converter_options)); if (!$self->{'generate'}) { mkdir "t/results/$self->{'name'}" if (! -d "t/results/$self->{'name'}"); } else { mkdir $srcdir."t/results/$self->{'name'}" if (! -d $srcdir."t/results/$self->{'name'}"); } if (!defined $parser_options->{'EXPANDED_FORMATS'}) { $parser_options->{'EXPANDED_FORMATS'} = [ 'docbook', 'html', 'xml', 'info', 'plaintext', 'latex']; # 'tex' is missed out here so that @ifnottex is expanded # in the tests. Put # {'EXPANDED_FORMATS' => ['tex']} # where you need @tex expanded in the t/*.t files. } my $initial_parser_options; # keep parser options to be able to pass to preamble formatting if ($arg_output) { $initial_parser_options = dclone($parser_options); } # get all the infos put in parser_options that are not actual # parser options but specifications for the test. my $test_file; if ($parser_options->{'test_file'}) { $test_file = $input_files_dir . $parser_options->{'test_file'}; delete $parser_options->{'test_file'}; } my $full_document; if (exists($parser_options->{'full_document'})) { $full_document = $parser_options->{'full_document'}; delete $parser_options->{'full_document'}; } my $test_input_file_name; if ($parser_options->{'test_input_file_name'}) { $test_input_file_name = $parser_options->{'test_input_file_name'}; delete $parser_options->{'test_input_file_name'}; } # test_split should not interfere with output formats conversion # as it is applied after the output formats. Splitting should not interfere # with conversion anyway. Output formats using information added by # splitting split themselves and reassociate all the root commands. # Splitting means associating root commands to a unit element in the structure # hash. Converters that do not split can ignore this structure hash key and # therefore should not be affected either. my $test_split = ''; if ($parser_options->{'test_split'}) { $test_split = $parser_options->{'test_split'}; if ($test_split ne 'node' and $test_split ne 'section') { warn "test_utils.pl: test_split should be node or section: $test_split\n"; } delete $parser_options->{'test_split'}; } # this is a Structuring phase option, but also needed # by converter, so set to converter, and use converter option # to check for the option if ($parser_options->{'SIMPLE_MENU'}) { $converter_options->{'SIMPLE_MENU'} = 1; delete $parser_options->{'SIMPLE_MENU'}; } my %tree_transformations; if ($parser_options->{'TREE_TRANSFORMATIONS'}) { my @option_transformations = split /,/, $parser_options->{'TREE_TRANSFORMATIONS'}; foreach my $transformation (@option_transformations) { if (Texinfo::Common::valid_tree_transformation($transformation)) { $tree_transformations{$transformation} = 1; } else { warn "$test_name: unknown tree transformation $transformation\n"; } } delete $parser_options->{'TREE_TRANSFORMATIONS'}; } # set FORMAT_MENU default to menu, which is the default for the parser. # get the same structuring warnings as texi2any. my $added_main_configurations = {'FORMAT_MENU' => 'menu', 'CHECK_MISSING_MENU_ENTRY' => 1}; # this is only used for index keys sorting in structuring foreach my $structuring_and_converter_option ('ENABLE_ENCODING') { if (defined($parser_options->{$structuring_and_converter_option})) { $added_main_configurations->{$structuring_and_converter_option} = $parser_options->{$structuring_and_converter_option}; $converter_options->{$structuring_and_converter_option} = $parser_options->{$structuring_and_converter_option}; delete $parser_options->{$structuring_and_converter_option}; } } foreach my $structuring_option ('CHECK_NORMAL_MENU_STRUCTURE', 'FORMAT_MENU') { if (defined($parser_options->{$structuring_option})) { $added_main_configurations->{$structuring_option} = $parser_options->{$structuring_option}; delete $parser_options->{$structuring_option}; } } if ($parser_options->{'skip'}) { if (!$self->{'generate'}) { SKIP: { skip "$test_name: $parser_options->{'skip'}", 1; ok 1, $test_name; } } return 1; } elsif (exists($parser_options->{'skip'})) { delete $parser_options->{'skip'}; } my %todos; if ($parser_options->{'todo'}) { %todos = %{$parser_options->{'todo'}}; delete $parser_options->{'todo'}; } my $split_pages = ''; if ($parser_options->{'test_split_pages'}) { $split_pages = $parser_options->{'test_split_pages'}; delete $parser_options->{'test_split_pages'}; } my @tested_formats; if ($parser_options and $parser_options->{'test_formats'}) { push @tested_formats, @{$parser_options->{'test_formats'}}; delete $parser_options->{'test_formats'}; } # reset Texinfo::Config informations to have isolated tests Texinfo::Config::GNUT_reinitialize_init_files(); my $init_file_directories = [$srcdir.'init/', $srcdir.'t/init/']; # the init file names are supposed to be binary strings. Since they # are not encoded anywhere, probably only non ascii file names should # be used. # FIXME what if srcdir is non ascii (srcdir is truly a binary string). if ($parser_options and $parser_options->{'init_files'}) { my $conf = {}; if (defined($locale_encoding)) { $conf->{'COMMAND_LINE_ENCODING'} = $locale_encoding; $conf->{'MESSAGE_ENCODING'} = $locale_encoding; } Texinfo::Config::GNUT_initialize_config('', $conf, {}); foreach my $filename (@{$parser_options->{'init_files'}}) { my $file = Texinfo::Common::locate_init_file($filename, $init_file_directories, 0); if (defined($file)) { Texinfo::Config::GNUT_load_init_file($file); } else { warn (sprintf("could not read init file %s", $filename)); } } delete $parser_options->{'init_files'}; } my $completed_parser_options = {'INCLUDE_DIRECTORIES' => [$srcdir.'t/include/'], 'DEBUG' => $self->{'DEBUG'}, %$parser_options}; my $main_configuration = Texinfo::MainConfig::new({ %$completed_parser_options, %$added_main_configurations }); my $parser = Texinfo::Parser::parser($completed_parser_options); # take the initial values to record only if there is something new # do a copy to compare the values and not the references my $initial_index_names = dclone(\%Texinfo::Commands::index_names); my $tree; if (!$test_file) { if ($full_document) { print STDERR " TEST FULL $test_name\n" if ($self->{'DEBUG'}); $tree = $parser->parse_texi_text($test_text); } else { print STDERR " TEST $test_name\n" if ($self->{'DEBUG'}); $tree = $parser->parse_texi_piece($test_text); } if (defined($test_input_file_name)) { # FIXME should we need to encode or do we assume that # $test_input_file_name is already bytes? $parser->{'info'}->{'input_file_name'} = $test_input_file_name; } } else { print STDERR " TEST $test_name ($test_file)\n" if ($self->{'DEBUG'}); $tree = $parser->parse_texi_file($test_file); } my $registrar = $parser->registered_errors(); if (not defined($tree)) { print STDERR "ERROR: parsing result undef\n"; my ($parser_errors, $parser_error_count) = $registrar->errors(); foreach my $error_message (@$parser_errors) { warn $error_message->{'error_line'} if ($error_message->{'type'} eq 'error'); } } # require instead of use for speed when this module is not needed require Texinfo::Transformations if (scalar(keys(%tree_transformations)) or $converter_options->{'SIMPLE_MENU'}); if ($tree_transformations{'fill_gaps_in_sectioning'}) { my ($filled_contents, $added_sections) = Texinfo::Transformations::fill_gaps_in_sectioning($tree); if (!defined($filled_contents)) { warn "$test_name: fill_gaps_in_sectioning transformation return no result. No section?\n"; } else { $tree->{'contents'} = $filled_contents; } } my ($labels, $targets_list, $nodes_list) = $parser->labels_information(); if ($converter_options->{'SIMPLE_MENU'}) { Texinfo::Transformations::set_menus_to_simple_menu($nodes_list); } my $parser_information = $parser->global_information(); Texinfo::Common::set_output_encodings($main_configuration, $parser_information); my $global_commands = $parser->global_commands_information(); if ($global_commands->{'novalidate'}) { $main_configuration->set_conf('novalidate', 1); } my $indices_information = $parser->indices_information(); if ($tree_transformations{'relate_index_entries_to_items'}) { Texinfo::Common::relate_index_entries_to_table_items_in_tree($tree, $indices_information); } if ($tree_transformations{'move_index_entries_after_items'}) { Texinfo::Common::move_index_entries_after_items_in_tree($tree); } if ($tree_transformations{'insert_nodes_for_sectioning_commands'}) { my ($modified_contents, $added_nodes) = Texinfo::Transformations::insert_nodes_for_sectioning_commands( $tree, $nodes_list, $targets_list, $labels); if (!defined($modified_contents)) { warn "$test_name: insert_nodes_for_sectioning_commands transformation return no result. No section?\n"; } else { $tree->{'contents'} = $modified_contents; } } my $refs = $parser->internal_references_information(); Texinfo::Structuring::associate_internal_references($registrar, $main_configuration, $parser_information, $labels, $refs); my $structure_information = {}; my ($sectioning_root, $sections_list) = Texinfo::Structuring::sectioning_structure($registrar, $main_configuration, $tree); if ($sectioning_root) { Texinfo::Structuring::warn_non_empty_parts($registrar, $main_configuration, $global_commands); $structure_information->{'sectioning_root'} = $sectioning_root; $structure_information->{'sections_list'} = $sections_list; } if ($tree_transformations{'complete_tree_nodes_menus'}) { Texinfo::Transformations::complete_tree_nodes_menus($tree); } elsif ($tree_transformations{'complete_tree_nodes_missing_menu'}) { Texinfo::Transformations::complete_tree_nodes_missing_menu($tree); } if ($tree_transformations{'regenerate_master_menu'}) { Texinfo::Transformations::regenerate_master_menu($main_configuration, $labels); } my $floats = $parser->floats_information(); Texinfo::Structuring::set_menus_node_directions($registrar, $main_configuration, $parser_information, $global_commands, $nodes_list, $labels); my $top_node = Texinfo::Structuring::nodes_tree($registrar, $main_configuration, $parser_information, $nodes_list, $labels); if (defined($top_node)) { $structure_information->{'top_node'} = $top_node; } if (defined($nodes_list) and (not defined($main_configuration->get_conf('FORMAT_MENU')) or $main_configuration->get_conf('FORMAT_MENU') eq 'menu')) { Texinfo::Structuring::complete_node_tree_with_menus($registrar, $main_configuration, $nodes_list, $top_node); Texinfo::Structuring::check_nodes_are_referenced($registrar, $main_configuration, $nodes_list, $top_node, $labels, $refs); } Texinfo::Structuring::number_floats($floats); my ($errors, $error_nrs) = $registrar->errors(); # FIXME maybe it would be good to compare $merged_index_entries? my $merged_index_entries = Texinfo::Structuring::merge_indices($indices_information); # only print indices information if it differs from the default # indices my $indices; my $trimmed_index_names = remove_keys($indices_information, ['index_entries']); $indices = {'index_names' => $trimmed_index_names} unless (Data::Compare::Compare($trimmed_index_names, $initial_index_names)); my ($sorted_index_entries, $index_entries_sort_strings); my $indices_sorted_sort_strings; if ($merged_index_entries) { ($sorted_index_entries, $index_entries_sort_strings) = Texinfo::Structuring::sort_indices($registrar, $main_configuration, $merged_index_entries, $indices_information); $indices_sorted_sort_strings = {}; foreach my $index_name (keys(%$sorted_index_entries)) { # index entries sort strings sorted in the order of the index entries if (scalar(@{$sorted_index_entries->{$index_name}})) { $indices_sorted_sort_strings->{$index_name} = []; foreach my $index_entry (@{$sorted_index_entries->{$index_name}}) { push @{$indices_sorted_sort_strings->{$index_name}}, $index_entries_sort_strings->{$index_entry}; } } } } # use the parser expanded formats to be similar to the main program, # and also to avoid having @inline* and raw output format @-commands # with elided contents especially parsed because they are ignored # and appearing as raw content in the tree in the output. my %expanded_formats_hash; if ($parser_options->{'EXPANDED_FORMATS'}) { foreach my $expanded_format (@{$parser_options->{'EXPANDED_FORMATS'}}) { $expanded_formats_hash{$expanded_format} = 1; } } my $converted_text = Texinfo::Convert::Text::convert_to_text($tree, {'TEST' => 1, 'expanded_formats_hash' => \%expanded_formats_hash}); my %converted; my %converted_errors; $converter_options = {} if (!defined($converter_options)); $converter_options->{'structuring'} = $structure_information; foreach my $format (@tested_formats) { if (defined($formats{$format})) { my $format_converter_options = {%$converter_options}; my $format_type = $format; if ($format_type =~ s/^file_//) { # the information that the results is a file is passed # through $format_converter_options->{'SUBDIR'} being defined my $base = "t/results/$self->{'name'}/$test_name/"; my $test_out_dir; if ($self->{'generate'}) { $base = $srcdir.$base; $test_out_dir = $base.'res_'.$format_type; if (-d $test_out_dir) { unlink_dir_files($test_out_dir); } } else { $test_out_dir = $base.'out_'.$format_type; } if (!defined($format_converter_options->{'SUBDIR'})) { mkdir ($base) if (! -d $base); if (! -d $test_out_dir) { mkdir ($test_out_dir); } else { # remove any files from previous runs unlink glob ("$test_out_dir/*"); } $format_converter_options->{'SUBDIR'} = "$test_out_dir/"; } } elsif (!defined($format_converter_options->{'OUTFILE'})) { $format_converter_options->{'OUTFILE'} = ''; } $format_converter_options->{'TEST'} = 1; $format_converter_options->{'INCLUDE_DIRECTORIES'} = [ $srcdir.'t/include/']; my $converter; ($converted_errors{$format}, $converted{$format}, $converter) = &{$formats{$format}}($self, $test_name, $format_type, $tree, $parser, $main_configuration, $format_converter_options); $converted_errors{$format} = undef if (!@{$converted_errors{$format}}); if ($format =~ /^file_/ and defined ($converted{$format})) { # This is certainly wrong, because the differences are made on # the output files which should be empty. Differences in output # will be missed. It is tempting to use such format to have # output() called by the converter and get the file headers and # footers output in the main test perl file, but it is incorrect. # It is better to do as for the html or latex cases, have a _text # format, like html_text for which convert() is called and have # output() be called for the main format name, for example html. warn "ERROR: $self->{'name'}: $test_name: $format: file test with result as text\n"; } # output converted result and errors in files if $arg_output is set if ($arg_output) { mkdir ("$output_files_dir/$self->{'name'}") if (! -d "$output_files_dir/$self->{'name'}"); my $extension; if ($extensions{$format_type}) { $extension = $extensions{$format_type}; } else { $extension = $format_type; } if (defined ($converted{$format})) { my $original_test_outfile = "$self->{'name'}/$test_name.$extension"; my $test_outfile = $original_test_outfile; if ($output_files{$original_test_outfile}) { warn "WARNING: $self->{'name'}: $test_name: $format: same name: $original_test_outfile " ."(".join("|", @{$output_files{$original_test_outfile}}).")\n"; push @{$output_files{$original_test_outfile}}, $format; $test_outfile = "$self->{'name'}/${test_name}_${format}.$extension"; # we also check that the file name with the format in name # has not already been output if ($output_files{$test_outfile}) { warn "ERROR: $self->{'name'}: $test_name: $format: same name with format: $test_outfile\n"; } else { $output_files{$test_outfile} = [$format]; } } else { $output_files{$original_test_outfile} = [$format]; } my $outfile = "$output_files_dir/$test_outfile"; if (!open (OUTFILE, ">$outfile")) { warn "ERROR: open $outfile: $!\n"; } else { # Texinfo::Convert::Converter::converter() calls # Texinfo::Common::set_output_encodings, so OUTPUT_PERL_ENCODING # should be set if possible in all the formats converters. my $output_file_encoding = $converter->get_conf('OUTPUT_PERL_ENCODING'); if (defined($output_file_encoding) and $output_file_encoding ne '') { binmode(OUTFILE, ":encoding($output_file_encoding)"); } else { warn "WARNING: $self->{'name'}: $test_name: $format: no encoding\n"; } if ($outfile_preamble{$format}) { if (ref($outfile_preamble{$format}) eq 'CODE') { print OUTFILE &{$outfile_preamble{$format}}($converter, 0, $initial_parser_options); } else { print OUTFILE $outfile_preamble{$format}->[0]; } } print OUTFILE $converted{$format}; if ($outfile_preamble{$format}) { if (ref($outfile_preamble{$format}) eq 'CODE') { print OUTFILE &{$outfile_preamble{$format}}($converter, 1, $initial_parser_options); } else { print OUTFILE $outfile_preamble{$format}->[1]; } } close (OUTFILE) or warn "Close $outfile: $!\n"; } } if ($converted_errors{$format}) { my $errors_file = "$output_files_dir/$self->{'name'}/${test_name}_$format.err"; if (!open (ERRFILE, ">$errors_file")) { warn "Open $errors_file: $!\n"; } else { foreach my $error_message (@{$converted_errors{$format}}) { my $error_line = $error_message->{'error_line'}; if (defined($locale_encoding)) { $error_line = Encode::encode($locale_encoding, $error_line); } if (defined($error_message->{'line_nr'})) { $error_line = $error_message->{'line_nr'} . ':' . ' ' . $error_line; } print ERRFILE $error_line; } close (ERRFILE) or warn "Close $errors_file: $!\n"; } } } } } my $directions_text; # remove the association of top-level commands with element units, in case # a converter split the document. # It may be noticed that this is only done after all conversions. This # means that depending on the order of converters call, trees feed to # converters may have element units. All the converters will have the # document_root as argument. # It could be possible to unsplit before each converter call, but it is # better to check that this does not have an effect on conversion. # Any conversion to Info, Plaintext or HTML (both with output and convert) # leads to splitting by the converter, and generally the tests order is # first plaintext or info then html, so splitting not having an effect # on conversion should be fairly well tested. See above the comment # near test_split with more explanation on why previous splitting should # not interfere with conversion. my $unsplit_needed = unsplit($tree); print STDERR " UNSPLIT: $test_name\n" if ($self->{'DEBUG'} and $unsplit_needed); my $elements; if ($test_split eq 'node') { $elements = Texinfo::Structuring::split_by_node($tree); } elsif ($test_split eq 'section') { $elements = Texinfo::Structuring::split_by_section($tree); } if ($test_split) { Texinfo::Structuring::elements_directions($parser, $labels, $elements); $directions_text = ''; foreach my $element (@$elements) { $directions_text .= Texinfo::Structuring::print_element_directions($element); } } if ($split_pages) { Texinfo::Structuring::split_pages($elements, $split_pages); } my $file = "t/results/$self->{'name'}/$test_name.pl"; my $new_file = $file.'.new'; my $split_result; if ($elements) { $split_result = $elements; foreach my $element (@$elements) { duplicate_tree_element_keys($element); } } else { $split_result = $tree; duplicate_tree_element_keys($tree); } { local $Data::Dumper::Purity = 1; local $Data::Dumper::Indent = 1; my $out_file; if (!$self->{'generate'}) { $out_file = $new_file; } else { $out_file = $srcdir.$file; } open (OUT, ">$out_file") or die "Open $out_file: $!\n"; binmode (OUT, ":encoding(utf8)"); print OUT 'use vars qw(%result_texis %result_texts %result_trees %result_errors '."\n". ' %result_indices %result_sectioning %result_nodes %result_menus'."\n". ' %result_floats %result_converted %result_converted_errors '."\n". ' %result_elements %result_directions_text %result_indices_sort_strings);'."\n\n"; print OUT 'use utf8;'."\n\n"; #print STDERR "Generate: ".Data::Dumper->Dump([$tree], ['$res']); # NOTE $test_name is in general used for directories and # file names, here it is used as a text string. If non ascii, it # should be a character string in internal perl codepoints as OUT # is encoded as utf8. It should also be encoded to be used as file name # in that case. my $out_result; { local $Data::Dumper::Sortkeys = \&filter_tree_keys; $out_result = Data::Dumper->Dump([$split_result], ['$result_trees{\''.$test_name.'\'}']); if ($out_result =~ /\r/) { # \r can be mangled upon reading if at end of line, with Useqq it is # protected local $Data::Dumper::Useqq = 1; $out_result = Data::Dumper->Dump([$split_result], ['$result_trees{\''.$test_name.'\'}']); } } my $texi_string_result = Texinfo::Convert::Texinfo::convert_to_texinfo($tree); $out_result .= "\n".'$result_texis{\''.$test_name.'\'} = \'' .protect_perl_string($texi_string_result)."';\n\n"; $out_result .= "\n".'$result_texts{\''.$test_name.'\'} = \'' .protect_perl_string($converted_text)."';\n\n"; { local $Data::Dumper::Sortkeys = \&filter_sectioning_keys; $out_result .= Data::Dumper->Dump([$sectioning_root], ['$result_sectioning{\''.$test_name.'\'}'])."\n" if ($sectioning_root); } if ($top_node) { { local $Data::Dumper::Sortkeys = \&filter_nodes_keys; $out_result .= Data::Dumper->Dump([$top_node], ['$result_nodes{\''.$test_name.'\'}'])."\n"; } { local $Data::Dumper::Sortkeys = \&filter_menus_keys; $out_result .= Data::Dumper->Dump([$top_node], ['$result_menus{\''.$test_name.'\'}'])."\n"; } } { local $Data::Dumper::Sortkeys = 1; # NOTE file names in error messages are bytes, there could be a # need to decode them if there were file names with non ascii # characters. # FIXME remove the NOTE if file names in error messages are not bytes # anymore $out_result .= Data::Dumper->Dump([$errors], ['$result_errors{\''.$test_name.'\'}']) ."\n\n"; $out_result .= Data::Dumper->Dump([$indices], ['$result_indices{\''.$test_name.'\'}']) ."\n\n" if ($indices); } if ($floats) { local $Data::Dumper::Sortkeys = \&filter_floats_keys; $out_result .= Data::Dumper->Dump([$floats], ['$result_floats{\''.$test_name.'\'}']) ."\n\n"; } if ($indices_sorted_sort_strings) { local $Data::Dumper::Sortkeys = 1; $out_result .= Data::Dumper->Dump([$indices_sorted_sort_strings], ['$result_indices_sort_strings{\''.$test_name.'\'}']) ."\n\n"; } if ($elements) { local $Data::Dumper::Sortkeys = \&filter_elements_keys; $out_result .= Data::Dumper->Dump([$elements], ['$result_elements{\''.$test_name.'\'}']) ."\n\n"; $out_result .= "\n".'$result_directions_text{\''.$test_name.'\'} = \'' .protect_perl_string($directions_text)."';\n\n"; } foreach my $format (@tested_formats) { if (defined($converted{$format})) { $out_result .= "\n".'$result_converted{\''.$format.'\'}->{\'' .$test_name.'\'} = \'' .protect_perl_string($converted{$format})."';\n\n"; } if (defined($converted_errors{$format})) { local $Data::Dumper::Sortkeys = 1; $out_result .= Data::Dumper->Dump([$converted_errors{$format}], ['$result_converted_errors{\''.$format.'\'}->{\''.$test_name.'\'}']) ."\n\n"; } } $out_result .= "1;\n"; print OUT $out_result; close (OUT); if ($self->{'generate'}) { print STDERR "--> $test_name\n"; } } if (!$self->{'generate'}) { %result_converted = (); require "$srcdir$file"; cmp_trimmed($split_result, $result_trees{$test_name}, \@avoided_keys_tree, $test_name.' tree'); cmp_trimmed($sectioning_root, $result_sectioning{$test_name}, \@avoided_keys_sectioning, $test_name.' sectioning' ); cmp_trimmed($top_node, $result_nodes{$test_name}, \@avoided_keys_nodes, $test_name.' nodes'); cmp_trimmed($top_node, $result_menus{$test_name}, \@avoided_keys_menus, $test_name.' menus'); ok (Data::Compare::Compare($errors, $result_errors{$test_name}), $test_name.' errors'); ok (Data::Compare::Compare($indices, $result_indices{$test_name}), $test_name.' indices'); ok (Data::Compare::Compare($indices_sorted_sort_strings, $result_indices_sort_strings{$test_name}), $test_name.' indices sort'); my $texi_result = Texinfo::Convert::Texinfo::convert_to_texinfo($tree); is ($texi_result, $result_texis{$test_name}, $test_name.' texi'); if ($todos{'text'}) { SKIP: { skip $todos{'text'}, 1; is ($converted_text, $result_texts{$test_name}, $test_name.' text'); } } else { is ($converted_text, $result_texts{$test_name}, $test_name.' text'); } $tests_count = $nr_comparisons; if (defined($result_directions_text{$test_name})) { cmp_trimmed($elements, $result_elements{$test_name}, \@avoided_keys_elements, $test_name.' elements'); $tests_count++; is ($directions_text, $result_directions_text{$test_name}, $test_name.' directions text'); $tests_count++; } if (@tested_formats) { foreach my $format (@tested_formats) { my $reference_exists; my $format_type = $format; if ($format_type =~ s/^file_//) { my $base = "t/results/$self->{'name'}/$test_name/"; my $reference_dir = "$srcdir$base".'res_'.$format_type; my $results_dir = $base.'out_'.$format_type; if (-d $reference_dir) { $reference_exists = 1; $tests_count += 1; my $errors = compare_dirs_files($reference_dir, $results_dir); if ($todos{$format}) { SKIP: { skip $todos{$format}, 1; ok (!defined($errors), $test_name.' converted '.$format) or diag (join("\n", @$errors)); } } else { ok (!defined($errors), $test_name.' converted '.$format) or diag (join("\n", @$errors)); } } else { print STDERR "\n$format $test_name: \n$results_dir\n"; } } elsif (!defined($result_converted{$format})) { my $result; if (defined($converted{$format})) { $result = $converted{$format}; } else { $result = 'UNDEF'."\n"; } print STDERR "\n$format $test_name:\n$result"; } else { $reference_exists = 1; $tests_count += 1; if ($todos{$format}) { SKIP: { skip $todos{$format}, 1; is ($converted{$format}, $result_converted{$format}->{$test_name}, $test_name.' converted '.$format); } } else { is ($converted{$format}, $result_converted{$format}->{$test_name}, $test_name.' converted '.$format); } } if ($reference_exists) { $tests_count += 1; ok (((not defined($converted_errors{$format}) and (not $result_converted_errors{$format} or not $result_converted_errors{$format}->{$test_name})) or Data::Compare::Compare($converted_errors{$format}, $result_converted_errors{$format}->{$test_name})), $test_name.' errors '.$format); } } } } return $tests_count; } # Main entry point for the tests. Called from *.t files. # $NAME - a string, name of test # $TEST_CASES - array of sub-tests # # variables set from command line: # If $ARG_TEST_CASE is set, only run that test. # $ARG_GENERATE set means to generate reference test results (-g from command line). # $ARG_DEBUG is used for debugging (-d from command line). # The $ARG_COMPLETE variable is the -c option, to create Texinfo files for the # test cases. sub run_all($$) { my $name = shift; my $test_cases = shift; my $test = new_test($name, $arg_generate, $arg_debug); my $ran_tests; if (scalar(@ARGV)) { $ran_tests = []; foreach my $arg_test_case (@ARGV) { foreach my $test_case (@$test_cases) { if ($test_case->[0] eq $arg_test_case) { push @$ran_tests, $test_case; last; } } } } else { $ran_tests = $test_cases; } if (!defined($ran_tests)) { die "No test\n"; } my $test_nrs = 0; foreach my $test_case (@$ran_tests) { if ($arg_complete) { $test->output_texi_file($test_case); } else { $test_nrs += $test->test($test_case); } } if ($arg_generate or $arg_complete) { plan tests => 1; } else { plan tests => (1 + $test_nrs); } } # Create a Texinfo file for a test case; used when -c option is given. sub output_texi_file($) { my $self = shift; my $test_case = shift; my $test_name = shift @$test_case; my $test_text = shift @$test_case; my $test_options = shift @$test_case; my $dir = "$generated_texis_dir/$self->{'name'}/"; mkdir "$generated_texis_dir/" or die unless (-d "$generated_texis_dir/"); mkdir $dir or die unless (-d $dir); my $file = "${dir}$test_name.texi"; print STDERR "texi: $test_name\n" if ($arg_debug); open (OUTFILE, ">$file") or die ("Open $file: $!\n"); my $encode = 1; my $first_line = "\\input texinfo \@c -*-texinfo-*-"; my $from_file; if (!defined($test_text)) { $from_file = 1; # We do not decode to character strings in internal perl encoding, # we get bytes and output bytes already encoded, mixing with # character strings containing ascii characters only. my $test_file; if ($test_options and $test_options->{'test_file'}) { $encode = 0; $test_file = $input_files_dir . $test_options->{'test_file'}; if (open (INFILE, $test_file)) { my $holdTerminator = $/; undef $/; $test_text = ; $/ = $holdTerminator; } else { die "Open $test_file: $!\n"; } } } my $node_top; if ($test_text =~ /^\@node +top[\s,]/mi or $test_text =~ /^\@node +top *$/mi) { $node_top = ''; } else { $node_top = "\@node Top\n"; unless ($test_text =~ /^\@top\s/m or $test_text =~ /^\@top *$/m) { $node_top .= "\@top $test_name\n"; } } my $added_chapter = ''; unless ($test_text =~ /^\@(chapter|unnumbered|appendix)\s/m or $test_text =~ /^\@(chapter|unnumbered|appendix) *$/m or $test_text =~ /^\@node +chap/mi) { # need a chapter or node after Top for LaTeX as Top node is ignored. if ($node_top ne '') { $added_chapter = "\@node chapter\n\@chapter chapter\n"; } else { print STDERR "WARNING: $test_name: top in test, no chapter added\n"; } } if ($from_file) { if ($node_top ne '' or $added_chapter ne '') { # \A matches beginning of string, even with /m if ($test_text =~ s/\A(\s*\\input texinfo(\.tex)? *\@.*)(\n|$)//m or $test_text =~ s/\A(\s*\\input texinfo(\.tex)? *)(\n|$)//m) { $first_line = $1; } } elsif ($test_text =~ /^\s*\\input texinfo(\.tex)? *\@/ or $test_text =~ /\A\s*\\input texinfo(\.tex)? *$/m) { $first_line = ""; } } my $bye = ''; if ($test_text !~ /\@bye *$/m and $test_text !~ /\@bye[\@ ]/) { $bye = '@bye'; } foreach my $output ($first_line, $node_top, $added_chapter) { print OUTFILE "$output\n" if ($output ne ''); } # $test_text is already encoded if read from a file, but if it is # a test string from a *.t file code, it is a perl character string # and is encoded here, to UTF-8 as it is the default Texinfo encoding. $test_text = Encode::encode('UTF-8', $test_text) if ($encode); # Always add a newline in the end. There may not be a newline for tests # defined as strings ending right after a character. chomp($test_text); print OUTFILE $test_text."\n"; print OUTFILE "$bye\n" if ($bye ne ''); close (OUTFILE) or die "Close $file: $!\n"; } 1;