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