1# t/* test support for the Perl modules.
2#
3# Copyright 2010-2019 Free Software Foundation, Inc.
4#
5# This program is free software; you can redistribute it and/or modify
6# it under the terms of the GNU General Public License as published by
7# the Free Software Foundation; either version 3 of the License,
8# or (at your option) any later version.
9#
10# This program is distributed in the hope that it will be useful,
11# but WITHOUT ANY WARRANTY; without even the implied warranty of
12# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
13# GNU General Public License for more details.
14#
15# You should have received a copy of the GNU General Public License
16# along with this program.  If not, see <http://www.gnu.org/licenses/>.
17#
18# Original author: Patrice Dumas <pertusus@free.fr>
19
20use strict;
21
22use 5.006;
23
24BEGIN {
25
26require Texinfo::ModulePath;
27Texinfo::ModulePath::init(undef, undef, 'updirs' => 2);
28
29# For consistent test results, use the C locale
30$ENV{LC_ALL} = 'C';
31
32} # end BEGIN
33
34use Test::More;
35
36use Texinfo::Parser;
37use Texinfo::Convert::Text;
38use Texinfo::Convert::Texinfo;
39use Texinfo::Structuring;
40use Texinfo::Convert::Plaintext;
41use Texinfo::Convert::Info;
42use Texinfo::Convert::HTML;
43use Texinfo::Convert::TexinfoXML;
44use Texinfo::Convert::DocBook;
45use File::Basename;
46use File::Copy;
47use File::Compare; # standard since 5.004
48use Data::Dumper;
49use Data::Compare;
50use Test::Deep;
51use Storable qw(dclone); # standard in 5.007003
52#use Data::Diff;
53#use Data::Transformer;
54#use Struct::Compare;
55use Getopt::Long qw(GetOptions);
56
57# File: test_file option.
58
59# FIXME Is it really useful?
60use vars qw(%result_texis %result_texts %result_trees %result_errors
61   %result_indices %result_sectioning %result_nodes %result_menus
62   %result_floats %result_converted %result_converted_errors
63   %result_elements %result_directions_text);
64
65my $strings_textdomain = 'texinfo_document';
66Locale::Messages->select_package ('gettext_pp');
67
68my $srcdir = $ENV{'srcdir'};
69my $locales_srcdir;
70if (defined($srcdir)) {
71  $srcdir =~ s/\/*$/\//;
72  $locales_srcdir = $srcdir;
73} else {
74  $srcdir = '';
75  $locales_srcdir = '.';
76}
77
78my $localesdir;
79foreach my $dir ("LocaleData", "$locales_srcdir/LocaleData") {
80  if (-d $dir) {
81    $localesdir = $dir;
82  }
83}
84
85if (! defined($localesdir)) {
86  warn "No locales directory found, some tests will fail\n";
87}
88
89Locale::Messages::bindtextdomain ('texinfo_document', $localesdir);
90Locale::Messages::bindtextdomain ('texinfo', $localesdir);
91
92my $generated_texis_dir = 't_texis';
93
94my $input_files_dir = $srcdir."t/input_files/";
95
96our $output_files_dir = 't/output_files/';
97foreach my $dir ('t', 't/results', $output_files_dir) {
98  my $error;
99  # to avoid a race conditon, first create the dir then test that it
100  # exists
101  mkdir $dir or $error = $!;
102  if (! -d $dir) {
103    die "mkdir $dir: $error\n";
104  }
105}
106
107ok(1);
108
109our %formats = (
110  'plaintext' => \&convert_to_plaintext,
111  'file_plaintext' => \&convert_to_plaintext,
112  'info' => \&convert_to_info,
113  'file_info' => \&convert_to_info,
114  'html' => \&convert_to_html,
115  'file_html' => \&convert_to_html,
116  'html_text' => \&convert_to_html,
117  'xml' => \&convert_to_xml,
118  'file_xml' => \&convert_to_xml,
119  'docbook' => \&convert_to_docbook,
120  'file_docbook' => \&convert_to_docbook,
121);
122
123our %extensions = (
124  'plaintext' => 'txt',
125  'html_text' => 'html',
126  'xml' => 'xml',
127  'docbook' => 'dbk',
128);
129
130my %xml_converter_defaults
131    = Texinfo::Convert::TexinfoXML::converter_defaults(undef, undef);
132my $XML_DTD_VERSION = $xml_converter_defaults{'TEXINFO_DTD_VERSION'};
133
134my %outfile_preamble = (
135  'docbook' => ['<?xml version="1.0"?>
136<!DOCTYPE book PUBLIC "-//OASIS//DTD DocBook XML V4.2//EN" "http://www.oasis-open.org/docbook/xml/4.2/docbookx.dtd" [
137  <!ENTITY tex "TeX">
138  <!ENTITY latex "LaTeX">
139]>
140'. "<book lang=\"en\">\n", "</book>\n"],
141  'xml' => ['<?xml version="1.0"?>
142'."<!DOCTYPE texinfo PUBLIC \"-//GNU//DTD TexinfoML V${XML_DTD_VERSION}//EN\" \"http://www.gnu.org/software/texinfo/dtd/${XML_DTD_VERSION}/texinfo.dtd\">
143".'<texinfo xml:lang="en">
144', "</texinfo>\n"],
145 'html_text' => ['<!DOCTYPE html PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN" "http://www.w3.org/TR/html4/loose.dtd">
146<html>
147<head>
148<title>Untitled Document</title>
149<meta name="resource-type" content="document">
150<meta name="distribution" content="global">
151<meta name="Generator" content="tp">
152<style type="text/css">
153<!--
154a.summary-letter {text-decoration: none}
155blockquote.indentedblock {margin-right: 0em}
156blockquote.smallindentedblock {margin-right: 0em; font-size: smaller}
157blockquote.smallquotation {font-size: smaller}
158div.display {margin-left: 3.2em}
159div.example {margin-left: 3.2em}
160div.lisp {margin-left: 3.2em}
161div.smalldisplay {margin-left: 3.2em}
162div.smallexample {margin-left: 3.2em}
163div.smalllisp {margin-left: 3.2em}
164kbd {font-style: oblique}
165pre.display {font-family: inherit}
166pre.format {font-family: inherit}
167pre.menu-comment {font-family: serif}
168pre.menu-preformatted {font-family: serif}
169pre.smalldisplay {font-family: inherit; font-size: smaller}
170pre.smallexample {font-size: smaller}
171pre.smallformat {font-family: inherit; font-size: smaller}
172pre.smalllisp {font-size: smaller}
173span.nocodebreak {white-space: nowrap}
174span.nolinebreak {white-space: nowrap}
175span.roman {font-family: serif; font-weight: normal}
176span.sansserif {font-family: sans-serif; font-weight: normal}
177ul.no-bullet {list-style: none}
178-->
179</style>
180</head>
181
182<body>
183',
184'</body>
185</html>
186']
187);
188
189our $arg_generate;
190our $arg_debug;
191our $arg_complete;
192our $arg_output;
193our $nr_comparisons = 8;
194
195Getopt::Long::Configure("gnu_getopt");
196GetOptions('g|generate' => \$arg_generate, 'd|debug=i' => \$arg_debug,
197           'c|complete' => \$arg_complete, 'o|output' => \$arg_output);
198
199our $arg_test_case = shift @ARGV;
200
201sub protect_perl_string($)
202{
203  my $string = shift;
204  $string =~ s/\\/\\\\/g;
205  $string =~ s/'/\\'/g;
206  return $string;
207}
208
209sub compare_dirs_files($$;$)
210{
211  my $dir1 = shift;
212  my $dir2 = shift;
213  my $ignore_files = shift;
214
215  my %dir1_files;
216  my %dir2_files;
217  my @errors;
218  my %ignored_files_hash;
219  foreach my $ignored_file (@$ignore_files) {
220    $ignored_files_hash{$ignored_file} = 1;
221  }
222  if (opendir(DIR1, $dir1)) {
223    my @files = readdir (DIR1);
224    foreach my $file (@files) {
225      next if (! -r "$dir1/$file" or ! -f "$dir1/$file"
226               or $ignored_files_hash{$file});
227      $dir1_files{$file} = 1;
228    }
229    closedir (DIR1);
230  } else {
231    push @errors, "readdir $dir1: $!";
232  }
233  if (opendir(DIR2, $dir2)) {
234    my @files = readdir (DIR2);
235    foreach my $file (@files) {
236      next if (! -r "$dir2/$file" or ! -f "$dir2/$file"
237               or $ignored_files_hash{$file});
238      $dir2_files{$file} = 1;
239    }
240    closedir (DIR2);
241  } else {
242    push @errors, "readdir $dir2: $!";
243  }
244  if (scalar(@errors)) {
245    return \@errors;
246  }
247  foreach my $file (sort(keys(%dir1_files))) {
248    if ($dir2_files{$file}) {
249      my $status = compare("$dir1/$file", "$dir2/$file");
250      if ($status) {
251        push @errors, "$dir1/$file and $dir2/$file differ: $status";
252      }
253      delete $dir2_files{$file};
254    } else {
255      push @errors, "No $file in $dir2";
256    }
257  }
258  foreach my $file (sort(keys(%dir2_files))) {
259    push @errors, "No $file in $dir1"
260  }
261  if (scalar(@errors)) {
262    return \@errors;
263  } else {
264    return undef;
265  }
266}
267
268#my $errors = compare_dirs_files('a', 'b',['nnn']);
269#if ($errors) {
270#  foreach my $error (@$errors) {
271#    warn $error."\n";
272#  }
273#}
274
275sub unlink_dir_files($;$)
276{
277  my $dir = shift;
278  my $ignore_files = shift;
279  my %ignored_files_hash;
280  foreach my $ignored_file (@$ignore_files) {
281    $ignored_files_hash{$ignored_file} = 1;
282  }
283  if (opendir(DIR, $dir)) {
284    my @files = readdir (DIR);
285    foreach my $file (@files) {
286      next if (! -f "$dir/$file"
287               or $ignored_files_hash{$file});
288      unlink "$dir/$file" or warn "Could not unlink $dir/$file: $!\n";
289    }
290    closedir (DIR);
291  } else {
292    warn "readdir $dir: $!";
293  }
294}
295
296#my $remove_parent = sub {my $h = shift; delete $h->{'parent'}};
297#my $transformer = Data::Transformer->new('hash'=>$remove_parent);
298sub remove_keys($$;$);
299sub remove_keys($$;$)
300{
301  my $root = shift;
302  my $deleted_keys = shift;
303  my $been_there = shift;
304  return undef if (!defined($root));
305  if (!defined($been_there)) {
306    #print STDERR "First call: $root\n";
307    $root = dclone ($root);
308    #print STDERR Data::Dumper->Dump([$root]);
309    $been_there = {};
310  }
311  #print STDERR "remove_keys: $root\n";
312  if (ref($root) eq 'HASH') {
313    foreach my $key (@$deleted_keys) {
314      if (exists($root->{$key})) {
315        delete ($root->{$key});
316        #print STDERR "Deleted $root $key\n";
317      }
318    }
319    $been_there->{$root} = 1;
320    foreach my $key (keys(%$root)) {
321      next if (!defined($root->{$key}) or !ref($root->{$key})
322               or (ref($root->{$key}) ne 'HASH'
323                    and ref($root->{$key}) ne 'ARRAY')
324               or exists($been_there->{$root->{$key}}));
325      #print STDERR "Recurse in $root $key\n";
326      remove_keys($root->{$key}, $deleted_keys, $been_there);
327    }
328  } elsif (ref($root) eq 'ARRAY') {
329    $been_there->{$root} = 1;
330    foreach my $element (@$root) {
331      next if (!defined($element) or !ref($element)
332               or (ref($element) ne 'HASH'
333                    and ref($element) ne 'ARRAY')
334               or exists($been_there->{$element}));
335
336      remove_keys($element, $deleted_keys, $been_there);
337    }
338  }
339  return $root;
340}
341
342sub duplicate_key_array($$)
343{
344  my $element = shift;
345  my $key = shift;
346
347  if (defined($element) and exists($element->{$key})
348      and defined($element->{$key})) {
349    my $new_content = [];
350    foreach my $array_item (@{$element->{$key}}) {
351      push @$new_content, $array_item;
352    }
353    $element->{$key} = $new_content;
354  }
355}
356
357# used to have a similar output as the XS parser
358# when using the pure perl parser.
359sub _duplicate_element_keys($$$)
360{
361  my $self = shift;
362  my $type = shift;
363  my $current = shift;
364
365  if (exists($current->{'line_nr'})) {
366    # cannot use dclone as dclone changes integers to strings
367    #$current->{'line_nr'} = dclone($current->{'line_nr'});
368    my $new_line_nr = {};
369    foreach my $key(keys(%{$current->{'line_nr'}})) {
370      $new_line_nr->{$key} = $current->{'line_nr'}->{$key};
371    }
372    $current->{'line_nr'} = $new_line_nr;
373  }
374
375  if (exists($current->{'extra'})) {
376    if (exists($current->{'extra'}->{'nodes_manuals'})
377        and defined($current->{'extra'}->{'nodes_manuals'})) {
378      foreach my $node_manual (@{$current->{'extra'}->{'nodes_manuals'}}) {
379        duplicate_key_array($node_manual, 'node_content');
380      }
381    }
382    if (exists($current->{'extra'}->{'type'})) {
383      duplicate_key_array($current->{'extra'}->{'type'}, 'content');
384    }
385    # only need to duplicate for @def* index entries
386    # in that case they are not duplicated in the XS parser output
387    if (exists($current->{'extra'}->{'index_entry'})
388        and exists($current->{'extra'}->{'def_command'})) {
389      duplicate_key_array($current->{'extra'}->{'index_entry'},
390        'content_normalized');
391    }
392    if (exists($current->{'extra'}->{'prototypes'})
393        and (defined($current->{'extra'}->{'prototypes'}))) {
394      foreach my $prototype (@{$current->{'extra'}->{'prototypes'}}) {
395        duplicate_key_array($prototype, 'contents');
396      }
397    }
398  }
399
400  return ($current);
401}
402
403sub duplicate_tree_element_keys($$)
404{
405  my $self = shift;
406  my $tree = shift;
407  return Texinfo::Common::modify_tree($self, $tree, \&_duplicate_element_keys);
408}
409
410sub cmp_trimmed($$$$)
411{
412  my $compared = shift;
413  my $reference = shift;
414  my $deleted_keys = shift;
415  my $test_name = shift;
416  my $trimmed = remove_keys($compared, $deleted_keys);
417no warnings 'recursion';
418  Test::Deep::cmp_deeply($trimmed, $reference, $test_name);
419}
420
421sub new_test($;$$$)
422{
423  my $name = shift;
424  my $generate = shift;
425  my $debug = shift;
426  my $test_formats = shift;
427  my $test = {'name' => $name, 'generate' => $generate,
428              'DEBUG' => $debug, 'test_formats' => $test_formats};
429
430  if ($generate) {
431    mkdir $srcdir."t/results/$name" if (! -d $srcdir."t/results/$name");
432  }
433  bless $test;
434  return $test;
435}
436
437my @contents_keys = ('contents', 'args', 'parent', 'line_nr', 'node_content',
438  'nodes_manuals', 'misc_content', 'invalid_nesting',
439  'block_command_line_contents', 'spaces_after_command');
440my @menus_keys = ('menu_next', 'menu_up', 'menu_prev', 'menu_up_hash');
441my @sections_keys = ('section_next', 'section_prev', 'section_up',
442  'section_childs', 'associated_node', 'part_associated_section',
443  'toplevel_prev', 'toplevel_next', 'toplevel_up');
444my @node_keys = ('node_next', 'node_prev', 'node_up', 'menus',
445  'associated_section');
446my %avoided_keys_tree;
447our @avoided_keys_tree = (@sections_keys, @menus_keys, @node_keys,
448   'menu_child', 'element_next', 'directions', 'page_next', 'remaining_args');
449foreach my $avoided_key(@avoided_keys_tree) {
450  $avoided_keys_tree{$avoided_key} = 1;
451}
452sub filter_tree_keys { [grep {!$avoided_keys_tree{$_}} ( sort keys %{$_[0]} )] }
453
454#my @avoided_compare_tree = (@avoided_keys_tree, 'parent', 'node_tree');
455
456my %avoided_keys_sectioning;
457my @avoided_keys_sectioning = ('section_next', @contents_keys, @menus_keys,
458  @node_keys, 'menu_child', 'toplevel_next');
459foreach my $avoided_key(@avoided_keys_sectioning) {
460  $avoided_keys_sectioning{$avoided_key} = 1;
461}
462sub filter_sectioning_keys { [grep {!$avoided_keys_sectioning{$_}}
463   ( sort keys %{$_[0]} )] }
464
465my %avoided_keys_nodes;
466my @avoided_keys_nodes = (@sections_keys, @contents_keys, @menus_keys);
467foreach my $avoided_key(@avoided_keys_nodes) {
468  $avoided_keys_nodes{$avoided_key} = 1;
469}
470sub filter_nodes_keys { [grep {!$avoided_keys_nodes{$_}}
471   ( sort keys %{$_[0]} )] }
472#my @avoided_compare_nodes = (@avoided_keys_nodes, 'node_up', 'node_prev');
473
474my %avoided_keys_menus;
475my @avoided_keys_menus = (@sections_keys, @contents_keys, @node_keys);
476foreach my $avoided_key(@avoided_keys_menus) {
477  $avoided_keys_menus{$avoided_key} = 1;
478}
479sub filter_menus_keys { [grep {!$avoided_keys_menus{$_}}
480   ( sort keys %{$_[0]} )] }
481
482my %avoided_keys_floats;
483my @avoided_keys_floats = (@sections_keys, @contents_keys, @node_keys,
484                           @menus_keys);
485foreach my $avoided_key(@avoided_keys_floats) {
486  $avoided_keys_floats{$avoided_key} = 1;
487}
488sub filter_floats_keys { [grep {!$avoided_keys_floats{$_}}
489   ( sort keys %{$_[0]} )] }
490
491my %avoided_keys_elements;
492my @avoided_keys_elements = (@contents_keys, @sections_keys, @node_keys,
493  'element_next', 'element_prev');
494foreach my $avoided_key(@avoided_keys_elements) {
495  $avoided_keys_elements{$avoided_key} = 1;
496}
497sub filter_elements_keys {[grep {!$avoided_keys_elements{$_}}
498   ( sort keys %{$_[0]} )] }
499
500sub set_converter_option_defaults($$$)
501{
502  my $converter_options = shift;
503  my $parser_options = shift;
504  my $format = shift;
505  $converter_options = {} if (!defined($converter_options));
506  if (!defined($converter_options->{'expanded_formats'})) {
507    $converter_options->{'expanded_formats'} = [$format];
508  }
509  return $converter_options;
510}
511
512sub close_files($)
513{
514  my $converter = shift;
515  my $converter_unclosed_files = $converter->converter_unclosed_files();
516  if ($converter_unclosed_files) {
517    foreach my $unclosed_file (keys(%$converter_unclosed_files)) {
518      if (!close($converter_unclosed_files->{$unclosed_file})) {
519        # FIXME or die?
520        warn(sprintf("tp_utils.pl: error on closing %s: %s\n",
521                    $converter_unclosed_files->{$unclosed_file}, $!));
522      }
523    }
524  }
525}
526
527sub convert_to_plaintext($$$$$$;$)
528{
529  my $self = shift;
530  my $test_name = shift;
531  my $format = shift;
532  my $tree = shift;
533  my $parser = shift;
534  my $parser_options = shift;
535  my $converter_options = shift;
536  $converter_options
537    = set_converter_option_defaults($converter_options,
538                                    $parser_options, $format);
539  if (!defined($converter_options->{'OUTFILE'})
540      and defined($converter_options->{'SUBDIR'})) {
541    $converter_options->{'OUTFILE'}
542      = $converter_options->{'SUBDIR'}.$test_name.".txt";
543  }
544
545  my $converter =
546     Texinfo::Convert::Plaintext->converter({'DEBUG' => $self->{'DEBUG'},
547                                             'parser' => $parser,
548                                             'output_format' => 'plaintext',
549                                             %$converter_options });
550  my $result;
551  if ($converter_options->{'OUTFILE'} eq '') {
552    $result = $converter->convert($tree);
553  } else {
554    $result = $converter->output($tree);
555    close_files($converter);
556    $result = undef if (defined($result and $result eq ''));
557  }
558  my ($errors, $error_nrs) = $converter->errors();
559  return ($errors, $result);
560}
561
562sub convert_to_info($$$$$;$)
563{
564  my $self = shift;
565  my $test_name = shift;
566  my $format = shift;
567  my $tree = shift;
568  my $parser = shift;
569  my $parser_options = shift;
570  my $converter_options = shift;
571  # FIXME plaintext too?
572  $converter_options
573    = set_converter_option_defaults($converter_options,
574                                    $parser_options, $format);
575
576  my $converter =
577     Texinfo::Convert::Info->converter ({'DEBUG' => $self->{'DEBUG'},
578                                         'parser' => $parser,
579                                         'output_format' => 'info',
580                                          %$converter_options });
581  my $result = $converter->output($tree);
582  close_files($converter);
583  die if (!defined($converter_options->{'SUBDIR'}) and !defined($result));
584  my ($errors, $error_nrs) = $converter->errors();
585  return ($errors, $result);
586}
587
588sub convert_to_html($$$$$$;$)
589{
590  my $self = shift;
591  my $test_name = shift;
592  my $format = shift;
593  my $tree = shift;
594  my $parser = shift;
595  my $parser_options = shift;
596  my $converter_options = shift;
597  $converter_options
598    = set_converter_option_defaults($converter_options,
599                                    $parser_options, 'html');
600
601  $converter_options->{'SPLIT'} = 0
602    if ($format eq 'html_text'
603        and !defined($parser_options->{'SPLIT'})
604        and !defined($converter_options->{'SPLIT'}));
605  if (!defined($converter_options->{'SIMPLE_MENU'})
606       and $parser_options->{'SIMPLE_MENU'}) {
607    $converter_options->{'SIMPLE_MENU'} = 1;
608  }
609  my $converter =
610     Texinfo::Convert::HTML->converter ({'DEBUG' => $self->{'DEBUG'},
611                                         'parser' => $parser,
612                                         'output_format' => 'html',
613                                          %$converter_options });
614  my $result;
615  if ($format eq 'html_text') {
616    $result = $converter->convert($tree);
617  } else {
618    $result = $converter->output($tree);
619    close_files($converter);
620  }
621  die if (!defined($converter_options->{'SUBDIR'}) and !defined($result));
622  my ($errors, $error_nrs) = $converter->errors();
623  return ($errors, $result);
624}
625
626sub convert_to_xml($$$$$$;$)
627{
628  my $self = shift;
629  my $test_name = shift;
630  my $format = shift;
631  my $tree = shift;
632  my $parser = shift;
633  my $parser_options = shift;
634  my $converter_options = shift;
635  $converter_options
636    = set_converter_option_defaults($converter_options,
637                                    $parser_options, 'xml');
638
639  my $converter =
640     Texinfo::Convert::TexinfoXML->converter ({'DEBUG' => $self->{'DEBUG'},
641                                         'parser' => $parser,
642                                         'output_format' => 'texinfoxml',
643                                          %$converter_options });
644
645  my $result;
646  if (defined($converter_options->{'OUTFILE'})
647      and $converter_options->{'OUTFILE'} eq '') {
648    $result = $converter->convert($tree);
649  } else {
650    $result = $converter->output($tree);
651    close_files($converter);
652    $result = undef if (defined($result and $result eq ''));
653  }
654  my ($errors, $error_nrs) = $converter->errors();
655  return ($errors, $result);
656}
657
658sub convert_to_docbook($$$$$$;$)
659{
660  my $self = shift;
661  my $test_name = shift;
662  my $format = shift;
663  my $tree = shift;
664  my $parser = shift;
665  my $parser_options = shift;
666  my $converter_options = shift;
667  $converter_options
668    = set_converter_option_defaults($converter_options,
669                                    $parser_options, 'docbook');
670
671  my $converter =
672     Texinfo::Convert::DocBook->converter ({'DEBUG' => $self->{'DEBUG'},
673                                         'parser' => $parser,
674                                         'output_format' => 'docbook',
675                                          %$converter_options });
676  my $result;
677  if (defined($converter_options->{'OUTFILE'})
678      and $converter_options->{'OUTFILE'} eq '') {
679    $result = $converter->convert($tree);
680  } else {
681    $result = $converter->output($tree);
682    close_files($converter);
683    $result = undef if (defined($result and $result eq ''));
684  }
685  my ($errors, $error_nrs) = $converter->errors();
686  return ($errors, $result);
687}
688
689# Run a single test case.  Each test case is an array
690# [TEST_NAME, TEST_TEXT, PARSER_OPTIONS, CONVERTER_OPTIONS]
691sub test($$)
692{
693  my $self = shift;
694  my $test_case = shift;
695
696  my $parser_options = {};
697  my $converter_options = undef;
698  my ($test_name, $test_text);
699
700  my $tests_count = 0;
701
702  $test_name = shift @$test_case;
703  die if (!defined($test_name));
704  $test_text = shift @$test_case;
705  $parser_options = shift @$test_case if (@$test_case);
706  $converter_options = shift @$test_case if (@$test_case);
707
708  if (!defined $parser_options->{'expanded_formats'}) {
709    $parser_options->{'expanded_formats'} = [
710      'docbook', 'html', 'xml', 'info', 'plaintext'];
711    #  'tex' is missed out here so that @ifnottex is expanded
712    # in the tests.  Put
713    #   {'expanded_formats' => ['tex']}
714    # where you need @tex expanded in the t/*.t files.
715  }
716
717  my $test_file;
718  if ($parser_options->{'test_file'}) {
719    $test_file = $input_files_dir . $parser_options->{'test_file'};
720    delete $parser_options->{'test_file'};
721  }
722  my $test_input_file_name;
723  if ($parser_options->{'test_input_file_name'}) {
724    $test_input_file_name = $parser_options->{'test_input_file_name'};
725    delete $parser_options->{'test_input_file_name'};
726  }
727  my $split = '';
728  if ($parser_options->{'test_split'}) {
729    $split = $parser_options->{'test_split'};
730    if ($split ne 'node' and $split ne 'section') {
731      warn "In test_utils.pl, test_split should be node or section, not $split\n";
732    }
733    delete $parser_options->{'test_split'};
734  }
735
736  if (!$self->{'generate'}) {
737    mkdir "t/results/$self->{'name'}" if (! -d "t/results/$self->{'name'}");
738  } else {
739    mkdir $srcdir."t/results/$self->{'name'}"
740      if (! -d $srcdir."t/results/$self->{'name'}");
741  }
742
743  my %todos;
744  if ($parser_options->{'todo'}) {
745    %todos = %{$parser_options->{'todo'}};
746    delete $parser_options->{'todo'};
747  }
748  my $split_pages = '';
749  if ($parser_options->{'test_split_pages'}) {
750    $split_pages = $parser_options->{'test_split_pages'};
751    delete $parser_options->{'test_split_pages'};
752  }
753
754  my @tested_formats;
755  if ($parser_options and $parser_options->{'test_formats'}) {
756    push @tested_formats, @{$parser_options->{'test_formats'}};
757    delete $parser_options->{'test_formats'};
758  }
759
760  my $parser = Texinfo::Parser::parser({'include_directories' => [
761                                          $srcdir.'t/include/'],
762                                        'DEBUG' => $self->{'DEBUG'},
763                                       %$parser_options});
764
765  # take the initial values to record only if there is something new
766  my $initial_index_names = $parser->indices_information();
767  # do a copy to compare the values and not the references
768  $initial_index_names = dclone($initial_index_names);
769  print STDERR "  TEST $test_name\n" if ($self->{'DEBUG'});
770  my $result;
771  if (!$test_file) {
772    $result = $parser->parse_texi_text($test_text, 1);
773    if (defined($test_input_file_name)) {
774      $parser->{'info'}->{'input_file_name'} = $test_input_file_name;
775    }
776  } else {
777    $result = $parser->parse_texi_file($test_file);
778  }
779  Texinfo::Structuring::associate_internal_references($parser);
780  my $floats = $parser->floats_information();
781
782  my $structure = Texinfo::Structuring::sectioning_structure($parser, $result);
783  if ($structure) {
784    Texinfo::Structuring::warn_non_empty_parts($parser);
785  }
786
787  Texinfo::Structuring::number_floats($floats);
788
789  Texinfo::Structuring::set_menus_node_directions($parser);
790  my $top_node = Texinfo::Structuring::nodes_tree($parser);
791
792  Texinfo::Structuring::complete_node_tree_with_menus($parser, $top_node);
793
794  my ($errors, $error_nrs) = $parser->errors();
795  my $index_names = $parser->indices_information();
796  # FIXME maybe it would be good to compare $merged_index_entries?
797  my $merged_index_entries
798     = Texinfo::Structuring::merge_indices($index_names);
799
800  # only print indices information if it differs from the default
801  # indices
802  my $indices;
803  my $trimmed_index_names = remove_keys($index_names, ['index_entries']);
804  $indices->{'index_names'} = $trimmed_index_names
805    unless (Data::Compare::Compare($trimmed_index_names, $initial_index_names));
806
807  my $sorted_index_entries;
808  if ($merged_index_entries) {
809    $sorted_index_entries
810      = Texinfo::Structuring::sort_indices_by_letter($parser,
811                                                     $merged_index_entries,
812                                                     $index_names);
813  }
814  if ($parser_options->{'SIMPLE_MENU'}) {
815    # require instead of use for speed when this module is not needed
816    require Texinfo::Transformations;
817    $parser->Texinfo::Transformations::set_menus_to_simple_menu();
818  }
819
820  my $converted_text = Texinfo::Convert::Text::convert($result, {'TEST' => 1});
821
822  my %converted;
823  my %converted_errors;
824  $converter_options = {} if (!defined($converter_options));
825  foreach my $format (@tested_formats) {
826    if (defined($formats{$format})) {
827      my $format_converter_options = {%$converter_options};
828      my $format_type = $format;
829      if ($format_type =~ s/^file_//) {
830        # the information that the results is a file is passed
831        # through $format_converter_options->{'SUBDIR'} being defined
832        my $base = "t/results/$self->{'name'}/$test_name/";
833        my $test_out_dir;
834        if ($self->{'generate'}) {
835          $base = $srcdir.$base;
836          $test_out_dir = $base.'res_'.$format_type;
837          if (-d $test_out_dir) {
838            unlink_dir_files($test_out_dir);
839          }
840        } else {
841          $test_out_dir = $base.'out_'.$format_type;
842        }
843        if (!defined($format_converter_options->{'SUBDIR'})) {
844          mkdir ($base)
845            if (! -d $base);
846          if (! -d $test_out_dir) {
847            mkdir ($test_out_dir);
848          } else {
849            # remove any files from previous runs
850            unlink glob ("$test_out_dir/*");
851          }
852          $format_converter_options->{'SUBDIR'} = "$test_out_dir/";
853        }
854      } elsif (!defined($format_converter_options->{'OUTFILE'})) {
855        $format_converter_options->{'OUTFILE'} = '';
856      }
857      $format_converter_options->{'TEST'} = 1;
858      $format_converter_options->{'include_directories'} = [
859                                          $srcdir.'t/include/'];
860      ($converted_errors{$format}, $converted{$format})
861           = &{$formats{$format}}($self, $test_name, $format_type,
862                                  $result, $parser,
863                                  $parser_options, $format_converter_options);
864      $converted_errors{$format} = undef if (!@{$converted_errors{$format}});
865
866      # output converted result and errors in files if $arg_output is set
867      if ($arg_output) {
868        mkdir ("$output_files_dir/$self->{'name'}")
869          if (! -d "$output_files_dir/$self->{'name'}");
870        my $extension;
871        if ($extensions{$format}) {
872          $extension = $extensions{$format};
873        } else {
874          $extension = $format;
875        }
876
877        if (defined ($converted{$format})) {
878          my $outfile = "$output_files_dir/$self->{'name'}/$test_name.$extension";
879          if (!open (OUTFILE, ">$outfile")) {
880            warn "Open $outfile: $!\n";
881          } else {
882            my $info = $parser->global_informations();
883            if ($info and $info->{'perl_encoding'}) {
884              binmode(OUTFILE, ":encoding($info->{'perl_encoding'})");
885            }
886            if ($outfile_preamble{$format}) {
887              print OUTFILE $outfile_preamble{$format}->[0];
888            }
889            print OUTFILE $converted{$format};
890            if ($outfile_preamble{$format}) {
891              print OUTFILE $outfile_preamble{$format}->[1];
892            }
893            close (OUTFILE) or warn "Close $outfile: $!\n";
894          }
895        }
896        if ($converted_errors{$format}) {
897          my $errors_file
898            = "$output_files_dir/$self->{'name'}/${test_name}_$extension.err";
899          if (!open (ERRFILE, ">$errors_file")) {
900            warn "Open $errors_file: $!\n";
901          } else {
902            foreach my $error_message (@{$converted_errors{$format}}) {
903              print ERRFILE $error_message->{'error_line'};
904            }
905            close (ERRFILE) or warn "Close $errors_file: $!\n";
906          }
907        }
908      }
909    }
910  }
911  my $directions_text;
912  # re-associate top level command with the document_root in case a converter
913  # split the document, by resetting their 'parent' key.
914  # It may be noticed that this is only done after all conversions.  This
915  # means that depending on the order of converters call, trees feed to
916  # converters may have a document_root as top level command parent or
917  # elements.  All the converters will have the document_root as argument.
918  Texinfo::Structuring::_unsplit($result);
919  my $elements;
920  if ($split eq 'node') {
921    $elements = Texinfo::Structuring::split_by_node($result);
922  } elsif ($split eq 'section') {
923    $elements = Texinfo::Structuring::split_by_section($result);
924  }
925  if ($split) {
926    Texinfo::Structuring::elements_directions($parser, $elements);
927    $directions_text = '';
928    foreach my $element (@$elements) {
929      $directions_text .= Texinfo::Structuring::_print_directions($element);
930    }
931  }
932  if ($split_pages) {
933    Texinfo::Structuring::split_pages($elements, $split_pages);
934  }
935
936  my $file = "t/results/$self->{'name'}/$test_name.pl";
937  my $new_file = $file.'.new';
938
939  my $split_result;
940  if ($elements) {
941    $split_result = $elements;
942    foreach my $element (@$elements) {
943      duplicate_tree_element_keys($parser, $element);
944    }
945  } else {
946    $split_result = $result;
947    duplicate_tree_element_keys($parser, $result);
948  }
949
950  {
951    local $Data::Dumper::Purity = 1;
952    local $Data::Dumper::Indent = 1;
953
954    my $out_file;
955    if (!$self->{'generate'}) {
956      $out_file = $new_file;
957    } else {
958      $out_file = $srcdir.$file;
959    }
960    open (OUT, ">$out_file") or die "Open $out_file: $!\n";
961    binmode (OUT, ":encoding(utf8)");
962    print OUT 'use vars qw(%result_texis %result_texts %result_trees %result_errors '."\n".
963              '   %result_indices %result_sectioning %result_nodes %result_menus'."\n".
964              '   %result_floats %result_converted %result_converted_errors '."\n".
965              '   %result_elements %result_directions_text);'."\n\n";
966    print OUT 'use utf8;'."\n\n";
967
968    #print STDERR "Generate: ".Data::Dumper->Dump([$result], ['$res']);
969    my $out_result;
970    {
971      local $Data::Dumper::Sortkeys = \&filter_tree_keys;
972      $out_result = Data::Dumper->Dump([$split_result], ['$result_trees{\''.$test_name.'\'}']);
973    }
974    my $texi_string_result = Texinfo::Convert::Texinfo::convert($result);
975    $out_result .= "\n".'$result_texis{\''.$test_name.'\'} = \''
976          .protect_perl_string($texi_string_result)."';\n\n";
977    $out_result .= "\n".'$result_texts{\''.$test_name.'\'} = \''
978          .protect_perl_string($converted_text)."';\n\n";
979    {
980      local $Data::Dumper::Sortkeys = \&filter_sectioning_keys;
981      $out_result .=  Data::Dumper->Dump([$structure],
982                           ['$result_sectioning{\''.$test_name.'\'}'])."\n"
983        if ($structure);
984    }
985    if ($top_node) {
986      {
987        local $Data::Dumper::Sortkeys = \&filter_nodes_keys;
988         $out_result .=  Data::Dumper->Dump([$top_node], ['$result_nodes{\''.$test_name.'\'}'])."\n";
989      }
990      {
991        local $Data::Dumper::Sortkeys = \&filter_menus_keys;
992         $out_result .=  Data::Dumper->Dump([$top_node], ['$result_menus{\''.$test_name.'\'}'])."\n";
993      }
994    }
995    {
996      local $Data::Dumper::Sortkeys = 1;
997      $out_result .= Data::Dumper->Dump([$errors], ['$result_errors{\''.$test_name.'\'}']) ."\n\n";
998      $out_result .= Data::Dumper->Dump([$indices], ['$result_indices{\''.$test_name.'\'}']) ."\n\n"
999         if ($indices);
1000    }
1001    if ($floats) {
1002      local $Data::Dumper::Sortkeys = \&filter_floats_keys;
1003      $out_result .= Data::Dumper->Dump([$floats], ['$result_floats{\''.$test_name.'\'}']) ."\n\n";
1004    }
1005    if ($elements) {
1006      local $Data::Dumper::Sortkeys = \&filter_elements_keys;
1007      $out_result .= Data::Dumper->Dump([$elements], ['$result_elements{\''.$test_name.'\'}']) ."\n\n";
1008      $out_result .= "\n".'$result_directions_text{\''.$test_name.'\'} = \''
1009        .protect_perl_string($directions_text)."';\n\n";
1010    }
1011    foreach my $format (@tested_formats) {
1012      if (defined($converted{$format})) {
1013        $out_result .= "\n".'$result_converted{\''.$format.'\'}->{\''
1014          .$test_name.'\'} = \''.protect_perl_string($converted{$format})."';\n\n";
1015      }
1016      if (defined($converted_errors{$format})) {
1017        local $Data::Dumper::Sortkeys = 1;
1018        $out_result .= Data::Dumper->Dump([$converted_errors{$format}],
1019                 ['$result_converted_errors{\''.$format.'\'}->{\''.$test_name.'\'}']) ."\n\n";
1020      }
1021    }
1022
1023    $out_result .= "1;\n";
1024    print OUT $out_result;
1025    close (OUT);
1026
1027    print STDERR "--> $test_name\n".Texinfo::Convert::Texinfo::convert($result)."\n"
1028            if ($self->{'generate'});
1029  }
1030  if (!$self->{'generate'}) {
1031    %result_converted = ();
1032    require "$srcdir$file";
1033
1034    cmp_trimmed($split_result, $result_trees{$test_name}, \@avoided_keys_tree,
1035                $test_name.' tree');
1036    cmp_trimmed($structure, $result_sectioning{$test_name},
1037                 \@avoided_keys_sectioning, $test_name.' sectioning' );
1038    cmp_trimmed($top_node, $result_nodes{$test_name}, \@avoided_keys_nodes,
1039                $test_name.' nodes');
1040    cmp_trimmed($top_node, $result_menus{$test_name}, \@avoided_keys_menus,
1041                $test_name.' menus');
1042
1043    ok (Data::Compare::Compare($errors, $result_errors{$test_name}),
1044        $test_name.' errors');
1045    ok (Data::Compare::Compare($indices, $result_indices{$test_name}),
1046        $test_name.' indices');
1047    ok (Texinfo::Convert::Texinfo::convert($result) eq $result_texis{$test_name},
1048         $test_name.' texi');
1049    if ($todos{'text'}) {
1050      SKIP: {
1051        skip $todos{'text'}, 1;
1052        ok ($converted_text eq $result_texts{$test_name}, $test_name.' text');
1053      }
1054    } else {
1055      ok ($converted_text eq $result_texts{$test_name}, $test_name.' text');
1056    }
1057    $tests_count = $nr_comparisons;
1058    if (defined($result_directions_text{$test_name})) {
1059      cmp_trimmed($elements, $result_elements{$test_name},
1060                  \@avoided_keys_elements, $test_name.' elements');
1061      $tests_count++;
1062      ok ($directions_text eq $result_directions_text{$test_name},
1063          $test_name.' directions text');
1064      $tests_count++;
1065    }
1066    if (@tested_formats) {
1067      foreach my $format (@tested_formats) {
1068        my $reference_exists;
1069        my $format_type = $format;
1070        if ($format_type =~ s/^file_//) {
1071          my $base = "t/results/$self->{'name'}/$test_name/";
1072          my $reference_dir = "$srcdir$base".'res_'.$format_type;
1073          my $results_dir = $base.'out_'.$format_type;
1074          if (-d $reference_dir) {
1075            $reference_exists = 1;
1076            $tests_count += 1;
1077            my $errors = compare_dirs_files($reference_dir, $results_dir);
1078            if ($todos{$format}) {
1079              SKIP: {
1080                skip $todos{$format}, 1;
1081                ok (!defined($errors), $test_name.' converted '.$format)
1082                  or diag (join("\n", @$errors));
1083              }
1084            } else {
1085              ok (!defined($errors), $test_name.' converted '.$format)
1086                or diag (join("\n", @$errors));
1087            }
1088          } else {
1089            print STDERR "\n$format $test_name: \n$results_dir\n";
1090          }
1091        } elsif (!defined($result_converted{$format})) {
1092          my $result;
1093          if (defined($converted{$format})) {
1094            $result = $converted{$format};
1095          } else {
1096            $result = 'UNDEF'."\n";
1097          }
1098          print STDERR "\n$format $test_name:\n$result";
1099        } else {
1100          $reference_exists = 1;
1101          $tests_count += 1;
1102          if ($todos{$format}) {
1103            SKIP: {
1104              skip $todos{$format}, 1;
1105              ok ($converted{$format}
1106                              eq $result_converted{$format}->{$test_name},
1107                   $test_name.' converted '.$format);
1108            }
1109          } else {
1110            ok ($converted{$format}
1111                           eq $result_converted{$format}->{$test_name},
1112                $test_name.' converted '.$format);
1113          }
1114        }
1115        if ($reference_exists) {
1116          $tests_count += 1;
1117          ok (Data::Compare::Compare($converted_errors{$format},
1118               $result_converted_errors{$format}->{$test_name}),
1119               $test_name.' errors '.$format);
1120        }
1121      }
1122    }
1123  }
1124  return $tests_count;
1125}
1126
1127# Main entry point for the tests.
1128#   $NAME - a string, name of test
1129#   $TEST_CASES - array of sub-tests
1130#   If $TEST_CASE_NAME is given, only run that test.
1131#   $GENERATE means to generate reference test results (-g from command line).
1132#   $DEBUG for debugging.
1133# The $ARG_COMPLETE variable is the -c option, to create Texinfo files for the
1134# test cases.
1135sub run_all($$;$$$)
1136{
1137  my $name = shift;
1138  my $test_cases = shift;
1139  my $test_case_name = shift;
1140  my $generate = shift;
1141  my $debug = shift;
1142
1143  my $test = new_test($name, $generate, $debug);
1144  my $ran_tests;
1145  if (defined($test_case_name)) {
1146    if ($test_case_name =~ /^\d+$/) {
1147      $ran_tests = [ $test_cases->[$test_case_name-1] ];
1148    } else {
1149      foreach my $test_case (@$test_cases) {
1150        if ($test_case->[0] eq $test_case_name) {
1151          $ran_tests = [ $test_case ];
1152          last;
1153        }
1154      }
1155    }
1156  } else {
1157    $ran_tests = $test_cases;
1158  }
1159
1160  if (!defined($ran_tests)) {
1161    die "No test\n";
1162  }
1163  my $test_nrs = 0;
1164
1165  foreach my $test_case (@$ran_tests) {
1166    if ($arg_complete) {
1167      $test->output_texi_file($test_case);
1168    } else {
1169      $test_nrs += $test->test($test_case);
1170    }
1171  }
1172  if ($generate or $arg_complete) {
1173    plan tests => 1;
1174  } else {
1175    plan tests => (1 + $test_nrs);
1176  }
1177}
1178
1179# Create a Texinfo file for a test case; used when -c option is given.
1180sub output_texi_file($)
1181{
1182  my $self = shift;
1183  my $test_case = shift;
1184  my $test_name = shift @$test_case;
1185  my $test_text = shift @$test_case;
1186  my $test_options = shift @$test_case;
1187
1188  my $dir = "$generated_texis_dir/$self->{'name'}/";
1189  mkdir "$generated_texis_dir/" or die
1190     unless (-d "$generated_texis_dir/");
1191  mkdir $dir or die
1192     unless (-d $dir);
1193  my $file = "${dir}$test_name.texi";
1194  open (OUTFILE, ">$file") or die ("Open $file: $!\n");
1195
1196  my $first_line = "\\input texinfo \@c -*-texinfo-*-";
1197  if (!defined($test_text)) {
1198    my $test_file;
1199    if ($test_options and $test_options->{'test_file'}) {
1200      $test_file = $input_files_dir . $test_options->{'test_file'};
1201      if (open (INFILE, $test_file)) {
1202        my $holdTerminator = $/;
1203        undef $/;
1204        $test_text = <INFILE>;
1205        $/ = $holdTerminator;
1206      } else {
1207        die "Open $test_file: $!\n";
1208      }
1209      if ($test_text =~ /^\\input texinfo *\@/m
1210          or $test_text =~ /^\\input texinfo *$/m) {
1211        $first_line = "";
1212      }
1213    }
1214  }
1215  my $setfilename;
1216  if ($test_text =~ /^\@setfilename/m) {
1217    $setfilename = ''
1218  } else {
1219    $setfilename = "\@setfilename $test_name.info\n";
1220  }
1221  my $node_top;
1222  my $top = '';
1223  if ($test_text =~ /^\@node +top[\s,]/mi or $test_text =~ /^\@node +top *$/mi) {
1224    $node_top = '';
1225  } else {
1226    $node_top = "\@node Top\n";
1227    unless ($test_text =~ /^\@top\s/m or $test_text =~ /^\@top *$/m) {
1228      $node_top .= "\@top $test_name\n";
1229    }
1230  }
1231  my $bye = '';
1232  if ($test_text !~ /^\@bye *$/m) {
1233    $bye = '@bye';
1234  }
1235  print OUTFILE "$first_line
1236
1237$setfilename
1238$node_top
1239
1240$test_text
1241
1242$bye\n";
1243  close (OUTFILE) or die "Close $file: $!\n";
1244}
1245
12461;
1247