1package GnumericTest; 2use strict; 3use Exporter; 4use File::Basename qw(fileparse); 5use Config; 6use XML::Parser; 7 8$| = 1; 9 10@GnumericTest::ISA = qw (Exporter); 11@GnumericTest::EXPORT = qw(test_sheet_calc test_valgrind 12 test_importer test_exporter test_roundtrip 13 test_csv_format_guessing 14 test_ssindex sstest test_command message subtest 15 test_tool 16 setup_python_environment 17 make_absolute 18 $ssconvert $sstest $ssdiff $ssgrep $gnumeric 19 $topsrc $top_builddir 20 $subtests $samples corpus $PERL $PYTHON); 21@GnumericTest::EXPORT_OK = qw(junkfile); 22 23use vars qw($topsrc $top_builddir $samples $default_subtests $default_corpus $PERL $PYTHON $verbose); 24use vars qw($ssconvert $ssindex $sstest $ssdiff $ssgrep $gnumeric); 25use vars qw($normalize_gnumeric); 26 27$PYTHON = undef; 28 29$PERL = $Config{'perlpath'}; 30$PERL .= $Config{'_exe'} if $^O ne 'VMS' && $PERL !~ m/$Config{'_exe'}$/i; 31 32if ($0 eq '-e') { 33 # Running as "perl -e '...'", so no idea about where we are 34 $topsrc = '.'; 35} else { 36 $topsrc = $0; 37 $topsrc =~ s|/[^/]+$|/..|; 38 $topsrc =~ s|/test/\.\.$||; 39} 40 41$top_builddir = ".."; 42$samples = "$topsrc/samples"; $samples =~ s{^\./+}{}; 43$ssconvert = "$top_builddir/src/ssconvert"; 44$ssindex = "$top_builddir/src/ssindex"; 45$sstest = "$top_builddir/src/sstest"; 46$ssdiff = "$top_builddir/src/ssdiff"; 47$ssgrep = "$top_builddir/src/ssgrep"; 48$gnumeric = "$top_builddir/src/gnumeric"; 49$normalize_gnumeric = "$PERL $topsrc/test/normalize-gnumeric"; 50$verbose = 0; 51$default_subtests = '*'; 52my $subtests = undef; 53$default_corpus = 'full'; 54my $user_corpus = undef; 55 56# ----------------------------------------------------------------------------- 57 58my @tempfiles; 59END { 60 unlink @tempfiles; 61} 62 63sub junkfile { 64 my ($fn) = @_; 65 push @tempfiles, $fn; 66} 67 68sub removejunk { 69 my ($fn) = @_; 70 unlink $fn; 71 72 if (@tempfiles && $fn eq $tempfiles[-1]) { 73 scalar (pop @tempfiles); 74 } 75} 76 77# ----------------------------------------------------------------------------- 78 79sub system_failure { 80 my ($program,$code) = @_; 81 82 if ($code == -1) { 83 die "failed to run $program: $!\n"; 84 } elsif ($code >> 8) { 85 my $sig = $code >> 8; 86 die "$program died due to signal $sig\n"; 87 } else { 88 die "$program exited with exit code $code\n"; 89 } 90} 91 92sub read_file { 93 my ($fn) = @_; 94 95 local (*FIL); 96 open (FIL, $fn) or die "Cannot open $fn: $!\n"; 97 local $/ = undef; 98 my $lines = <FIL>; 99 close FIL; 100 101 return $lines; 102} 103 104sub write_file { 105 my ($fn,$contents) = @_; 106 107 local (*FIL); 108 open (FIL, ">$fn.tmp") or die "Cannot create $fn.tmp: $!\n"; 109 print FIL $contents; 110 close FIL; 111 rename "$fn.tmp", $fn; 112} 113 114sub update_file { 115 my ($fn,$contents) = @_; 116 117 my @stat = stat $fn; 118 die "Cannot stat $fn: $!\n" unless @stat > 2; 119 120 &write_file ($fn,$contents); 121 122 chmod $stat[2], $fn or 123 die "Cannot chmod $fn: $!\n"; 124} 125 126# Print a string with each line prefixed by "| ". 127sub dump_indented { 128 my ($txt) = @_; 129 return if $txt eq ''; 130 $txt =~ s/^/| /gm; 131 $txt = "$txt\n" unless substr($txt, -1) eq "\n"; 132 print STDERR $txt; 133} 134 135sub find_program { 136 my ($p, $nofail) = @_; 137 138 if ($p =~ m{/}) { 139 return $p if -x $p; 140 } else { 141 my $PATH = exists $ENV{'PATH'} ? $ENV{'PATH'} : ''; 142 foreach my $dir (split (':', $PATH)) { 143 $dir = '.' if $dir eq ''; 144 my $tentative = "$dir/$p"; 145 return $tentative if -x $tentative; 146 } 147 } 148 149 return undef if $nofail; 150 151 &report_skip ("$p is missing"); 152} 153 154# ----------------------------------------------------------------------------- 155 156sub message { 157 my ($message) = @_; 158 print "-" x 79, "\n"; 159 my $me = $0; 160 $me =~ s|^.*/||; 161 foreach (split (/\n/, $message)) { 162 print "$me: $_\n"; 163 } 164} 165 166# ----------------------------------------------------------------------------- 167 168sub subtest { 169 my ($q) = @_; 170 171 my $res = 0; 172 foreach my $t (split (',', $subtests || $default_subtests)) { 173 if ($t eq '*' || $t eq $q) { 174 $res = 1; 175 next; 176 } elsif ($t eq '-*' || $t eq "-$q") { 177 $res = 0; 178 next; 179 } 180 } 181 return $res; 182} 183 184# ----------------------------------------------------------------------------- 185 186my @dist_corpus = 187 ("$samples/regress.gnumeric", 188 "$samples/excel/address.xls", 189 "$samples/excel/bitwise.xls", 190 "$samples/excel/datefuns.xls", 191 "$samples/excel/dbfuns.xls", 192 "$samples/excel/engfuns.xls", 193 "$samples/excel/finfuns.xls", 194 "$samples/excel/functions.xls", 195 "$samples/excel/infofuns.xls", 196 "$samples/excel/logfuns.xls", 197 "$samples/excel/lookfuns2.xls", 198 "$samples/excel/lookfuns.xls", 199 "$samples/excel/mathfuns.xls", 200 "$samples/excel/objs.xls", 201 "$samples/excel/operator.xls", 202 "$samples/excel/sort.xls", 203 "$samples/excel/statfuns.xls", 204 "$samples/excel/textfuns.xls", 205 "$samples/excel/yalta2008.xls", 206 "$samples/excel12/cellstyle.xlsx", 207 "$samples/excel12/database.xlsx", 208 "$samples/excel12/ifs-funcs.xlsx", 209 "$samples/excel12/countif.xlsx", 210 "$samples/crlibm.gnumeric", 211 "$samples/amath.gnumeric", 212 "$samples/gamma.gnumeric", 213 "$samples/linest.xls", 214 "$samples/vba-725220.xls", 215 "$samples/sumif.xls", 216 "$samples/array-intersection.xls", 217 "$samples/arrays.xls", 218 "$samples/docs-samples.gnumeric", 219 "$samples/ftest.xls", 220 "$samples/ttest.xls", 221 "$samples/chitest.xls", 222 "$samples/vdb.gnumeric", 223 "$samples/numbermatch.gnumeric", 224 "$samples/numtheory.gnumeric", 225 "$samples/solver/afiro.mps", 226 "$samples/solver/blend.mps", 227 "$samples/auto-filter-tests.gnumeric", 228 "$samples/cell-comment-tests.gnumeric", 229 "$samples/colrow-tests.gnumeric", 230 "$samples/cond-format-tests.gnumeric", 231 "$samples/format-tests.gnumeric", 232 "$samples/formula-tests.gnumeric", 233 "$samples/graph-tests.gnumeric", 234 "$samples/hlink-tests.gnumeric", 235 "$samples/intersection-tests.gnumeric", 236 "$samples/merge-tests.gnumeric", 237 "$samples/names-tests.gnumeric", 238 "$samples/number-tests.gnumeric", 239 "$samples/object-tests.gnumeric", 240 "$samples/page-setup-tests.gnumeric", 241 "$samples/rich-text-tests.gnumeric", 242 "$samples/sheet-formatting-tests.gnumeric", 243 "$samples/sheet-names-tests.gnumeric", 244 "$samples/sheet-tab-tests.gnumeric", 245 "$samples/solver-tests.gnumeric", 246 "$samples/split-panes-tests.gnumeric", 247 "$samples/string-tests.gnumeric", 248 "$samples/merge-tests.gnumeric", 249 "$samples/selection-tests.gnumeric", 250 "$samples/style-tests.gnumeric", 251 "$samples/validation-tests.gnumeric", 252 ); 253 254my @full_corpus = 255 ("$samples/excel/chart-tests-excel.xls", # Too big 256 @dist_corpus); 257 258 259sub corpus { 260 my ($c) = @_; 261 262 my $corpus = ($c || $user_corpus || $default_corpus); 263 if ($corpus eq 'full') { 264 return @full_corpus; 265 } elsif ($corpus eq 'dist') { 266 return @dist_corpus; 267 } elsif ($corpus =~ /^random:(\d+)$/) { 268 my $n = $1; 269 my @corpus = grep { -r $_; } @full_corpus; 270 while ($n < @corpus) { 271 my $i = int (rand() * @corpus); 272 splice @corpus, $i, 1; 273 } 274 return @corpus; 275 } elsif ($corpus =~ m{^/(.*)/$}) { 276 my $rx = $1; 277 my @corpus = grep { /$rx/ } @full_corpus; 278 return @corpus; 279 } else { 280 die "Invalid corpus specification\n"; 281 } 282} 283 284# ----------------------------------------------------------------------------- 285 286sub test_command { 287 my ($cmd,$test) = @_; 288 289 print STDERR "# $cmd\n" if $verbose; 290 my $output = `$cmd 2>&1`; 291 my $err = $?; 292 &dump_indented ($output); 293 die "Failed command: $cmd\n" if $err; 294 295 local $_ = $output; 296 if (&$test ($output)) { 297 print STDERR "Pass\n"; 298 } else { 299 die "Fail\n"; 300 } 301} 302 303# ----------------------------------------------------------------------------- 304 305sub sstest { 306 my $test = shift @_; 307 my $expected = shift @_; 308 309 my $cmd = "earg ($sstest, $test); 310 print STDERR "# $cmd\n" if $verbose; 311 my $actual = `$cmd 2>&1`; 312 my $err = $?; 313 die "Failed command: $cmd\n" if $err; 314 315 my $ok; 316 if (ref $expected) { 317 local $_ = $actual; 318 $ok = &$expected ($_); 319 if (!$ok) { 320 foreach (split ("\n", $actual)) { 321 print "| $_\n"; 322 } 323 } 324 } else { 325 my @actual = split ("\n", $actual); 326 chomp @actual; 327 while (@actual > 0 && $actual[-1] eq '') { 328 my $dummy = pop @actual; 329 } 330 331 my @expected = split ("\n", $expected); 332 chomp @expected; 333 while (@expected > 0 && $expected[-1] eq '') { 334 my $dummy = pop @expected; 335 } 336 337 my $i = 0; 338 while ($i < @actual && $i < @expected) { 339 last if $actual[$i] ne $expected[$i]; 340 $i++; 341 } 342 if ($i < @actual || $i < @expected) { 343 $ok = 0; 344 print STDERR "Differences between actual and expected on line ", ($i + 1), ":\n"; 345 print STDERR "Actual : ", ($i < @actual ? $actual[$i] : "-"), "\n"; 346 print STDERR "Expected: ", ($i < @expected ? $expected[$i] : "-"), "\n"; 347 } else { 348 $ok = 1; 349 } 350 } 351 352 if ($ok) { 353 print STDERR "Pass\n"; 354 } else { 355 die "Fail.\n\n"; 356 } 357} 358 359# ----------------------------------------------------------------------------- 360 361sub test_sheet_calc { 362 my $file = shift @_; 363 my $pargs = (ref $_[0]) ? shift @_ : []; 364 my ($range,$expected) = @_; 365 366 &report_skip ("file $file does not exist") unless -r $file; 367 368 my $tmp = fileparse ($file); 369 $tmp =~ s/\.[a-zA-Z0-9]+$/.csv/; 370 &junkfile ($tmp); 371 372 my $cmd = "$ssconvert " . "earg (@$pargs, '--recalc', "--export-range=$range", $file, $tmp); 373 print STDERR "# $cmd\n" if $verbose; 374 my $code = system ("$cmd 2>&1 | sed -e 's/^/| /' "); 375 &system_failure ($ssconvert, $code) if $code; 376 377 my $actual = &read_file ($tmp); 378 379 my $ok; 380 if (ref $expected) { 381 local $_ = $actual; 382 $ok = &$expected ($_); 383 } else { 384 $ok = ($actual eq $expected); 385 } 386 387 &removejunk ($tmp); 388 389 if ($ok) { 390 print STDERR "Pass\n"; 391 } else { 392 $actual =~ s/\s+$//; 393 &dump_indented ($actual); 394 die "Fail.\n\n"; 395 } 396} 397 398# ----------------------------------------------------------------------------- 399 400my $import_db = 'import-db'; 401 402# Modes: 403# check: check that conversion produces right file 404# create-db: save the current corresponding .gnumeric 405# diff: diff conversion against saved .gnumeric 406# update-SHA-1: update $0 to show current SHA-1 [validate first!] 407 408sub test_importer { 409 my ($file,$sha1,$mode) = @_; 410 411 my $tmp = fileparse ($file); 412 ($tmp =~ s/\.[a-zA-Z0-9]+$/.gnumeric/ ) or ($tmp .= '.gnumeric'); 413 if ($mode eq 'create-db') { 414 -d $import_db or mkdir ($import_db, 0777) or 415 die "Cannot create $import_db: $!\n"; 416 $tmp = "$import_db/$tmp"; 417 } else { 418 &junkfile ($tmp); 419 } 420 421 &report_skip ("file $file does not exist") unless -r $file; 422 423 my $code = system ("$ssconvert '$file' '$tmp' 2>&1 | sed -e 's/^/| /'"); 424 &system_failure ($ssconvert, $code) if $code; 425 426 my $htxt = `zcat -f '$tmp' | $normalize_gnumeric | sha1sum`; 427 my $newsha1 = lc substr ($htxt, 0, 40); 428 die "SHA-1 failure\n" unless $newsha1 =~ /^[0-9a-f]{40}$/; 429 430 if ($mode eq 'check') { 431 if ($sha1 ne $newsha1) { 432 die "New SHA-1 is $newsha1; expected was $sha1\n"; 433 } 434 print STDERR "Pass\n"; 435 } elsif ($mode eq 'create-db') { 436 if ($sha1 ne $newsha1) { 437 warn ("New SHA-1 is $newsha1; expected was $sha1\n"); 438 } 439 # No file to remove 440 return; 441 } elsif ($mode eq 'diff') { 442 my $saved = "$import_db/$tmp"; 443 die "$saved not found\n" unless -r $saved; 444 445 my $tmp1 = "$tmp-old"; 446 &junkfile ($tmp1); 447 my $code1 = system ("zcat -f '$saved' >'$tmp1'"); 448 &system_failure ('zcat', $code1) if $code1; 449 450 my $tmp2 = "$tmp-new"; 451 &junkfile ($tmp2); 452 my $code2 = system ("zcat -f '$tmp' >'$tmp2'"); 453 &system_failure ('zcat', $code2) if $code2; 454 455 my $code3 = system ('diff', @ARGV, $tmp1, $tmp2); 456 457 &removejunk ($tmp2); 458 &removejunk ($tmp1); 459 } elsif ($mode =~ /^update-(sha|SHA)-?1/) { 460 if ($sha1 ne $newsha1) { 461 my $script = &read_file ($0); 462 my $count = ($script =~ s/\b$sha1\b/$newsha1/g); 463 die "SHA-1 found in script $count times\n" unless $count == 1; 464 &update_file ($0, $script); 465 } 466 return; 467 } else { 468 die "Invalid mode \"$mode\"\n"; 469 } 470 471 &removejunk ($tmp); 472} 473 474# ----------------------------------------------------------------------------- 475 476sub test_exporter { 477 my ($file,$ext) = @_; 478 479 &report_skip ("file $file does not exist") unless -r $file; 480 481 my $tmp = fileparse ($file); 482 $tmp =~ s/\.([a-zA-Z0-9]+)$//; 483 $ext = $1 unless defined $ext; 484 $ext or die "Must have extension for export test."; 485 my $code; 486 my $keep = 0; 487 488 my $tmp1 = "$tmp.gnumeric"; 489 &junkfile ($tmp1) unless $keep; 490 { 491 my $cmd = "earg ($ssconvert, $file, $tmp1); 492 print STDERR "# $cmd\n" if $verbose; 493 my $code = system ("$cmd 2>&1 | sed -e 's/^/| /'"); 494 &system_failure ($ssconvert, $code) if $code; 495 } 496 497 my $tmp2 = "$tmp-new.$ext"; 498 &junkfile ($tmp2) unless $keep; 499 { 500 my $cmd = "earg ($ssconvert, $file, $tmp2); 501 print STDERR "# $cmd\n" if $verbose; 502 my $code = system ("$cmd 2>&1 | sed -e 's/^/| /'"); 503 &system_failure ($ssconvert, $code) if $code; 504 } 505 506 my $tmp3 = "$tmp-new.gnumeric"; 507 &junkfile ($tmp3) unless $keep; 508 { 509 my $cmd = "earg ($ssconvert, $tmp2, $tmp3); 510 print STDERR "# $cmd\n" if $verbose; 511 my $code = system ("$cmd 2>&1 | sed -e 's/^/| /'"); 512 &system_failure ($ssconvert, $code) if $code; 513 } 514 515 my $tmp4 = "$tmp.xml"; 516 &junkfile ($tmp4) unless $keep; 517 $code = system ("earg ("zcat", "-f", $tmp1) . "| $normalize_gnumeric >" . "earg ($tmp4)); 518 &system_failure ('zcat', $code) if $code; 519 520 my $tmp5 = "$tmp-new.xml"; 521 &junkfile ($tmp5) unless $keep; 522 $code = system ("earg ("zcat" , "-f", $tmp3) . " | $normalize_gnumeric >" . "earg ($tmp5)); 523 &system_failure ('zcat', $code) if $code; 524 525 $code = system ('diff', '-u', $tmp4, $tmp5); 526 &system_failure ('diff', $code) if $code; 527 528 print STDERR "Pass\n"; 529} 530 531# ----------------------------------------------------------------------------- 532 533sub test_csv_format_guessing { 534 my (%args) = @_; 535 my $data = $args{'data'}; 536 537 my $keep = 0; 538 539 my $datafn = "test-data.csv"; 540 &junkfile ($datafn) unless $keep; 541 &write_file ($datafn, $data); 542 543 my $outfn = "test-data.gnumeric"; 544 &junkfile ($outfn) unless $keep; 545 546 local $ENV{'GNM_DEBUG'} = 'stf'; 547 my $cmd = "earg ($ssconvert, $datafn, $outfn); 548 print STDERR "# $cmd\n" if $verbose; 549 my $out = `$cmd 2>&1`; 550 551 if ($out !~ m/^\s*fmt\.0\s*=\s*(\S+)\s*$/m) { 552 die "Failed to guess any format\n"; 553 } 554 my $guessed = $1; 555 556 my $ok; 557 { 558 local $_ = $guessed; 559 $ok = &{$args{'format'}} ($_); 560 } 561 562 if ($verbose || !$ok) { 563 print STDERR "Data:\n"; 564 foreach (split ("\n", $data)) { 565 print STDERR "| $_\n"; 566 } 567 print STDERR "Result:\n"; 568 foreach (split ("\n", $out)) { 569 print STDERR "| $_\n"; 570 } 571 } 572 573 die "Guessed wrong format: $guessed\n" unless $ok; 574 575 if (exists $args{'decimal'}) { 576 if ($out !~ m/^\s*fmt\.0\.dec\s*=\s*(\S+)\s*$/m) { 577 die "Failed to guess any decimal separator\n"; 578 } 579 my $guessed = $1; 580 my $ok = ($1 eq $args{'decimal'}); 581 582 die "Guessed wrong decimal separator: $guessed\n" unless $ok; 583 } 584 585 if (exists $args{'thousand'}) { 586 if ($out !~ m/^\s*fmt\.0\.thou\s*=\s*(\S+)\s*$/m) { 587 die "Failed to guess any thousands separator\n"; 588 } 589 my $guessed = $1; 590 my $ok = ($1 eq $args{'thousand'}); 591 592 die "Guessed wrong thousands separator: $guessed\n" unless $ok; 593 } 594 595 &removejunk ($outfn) unless $keep; 596 &removejunk ($datafn) unless $keep; 597} 598 599# ----------------------------------------------------------------------------- 600 601# The BIFF formats leave us with a msole:codepage property 602my $drop_codepage_filter = 603 "$PERL -p -e '\$_ = \"\" if m{<meta:user-defined meta:name=.msole:codepage.}'"; 604 605my $drop_generator_filter = 606 "$PERL -p -e '\$_ = \"\" if m{<meta:generator>}'"; 607 608# BIFF7 doesn't store cell comment author 609my $no_author_filter = "$PERL -p -e 's{ Author=\"[^\"]*\"}{};'"; 610 611# BIFF7 cannot store rich text comments 612my $no_rich_comment_filter = "$PERL -p -e 'if (/gnm:CellComment/) { s{ TextFormat=\"[^\"]*\"}{}; }'"; 613 614# Excel cannot have superscript and subscript at the same time 615my $supersub_filter = "$PERL -p -e 's{\\[superscript=1:(\\d+):(\\d+)\\]\\[subscript=1:(\\d+):\\2\\]}{[superscript=1:\$1:\$3][subscript=1:\$3:\$2]};'"; 616 617my $noframe_filter = "$PERL -p -e '\$_ = \"\" if m{<gnm:SheetWidgetFrame .*/>}'"; 618 619my $noasindex_filter = "$PERL -p -e 'if (/gnm:SheetWidget(List|Combo)/) { s{( OutputAsIndex=)\"\\d+\"}{\$1\"0\"}; }'"; 620 621sub normalize_filter { 622 my ($f) = @_; 623 return 'cat' unless defined $f; 624 625 $f =~ s/\bstd:drop_codepage\b/$drop_codepage_filter/; 626 $f =~ s/\bstd:drop_generator\b/$drop_generator_filter/; 627 $f =~ s/\bstd:no_author\b/$no_author_filter/; 628 $f =~ s/\bstd:no_rich_comment\b/$no_rich_comment_filter/; 629 $f =~ s/\bstd:supersub\b/$supersub_filter/; 630 $f =~ s/\bstd:noframewidget\b/$noframe_filter/; 631 $f =~ s/\bstd:nocomboasindex\b/$noasindex_filter/; 632 633 return $f; 634} 635 636# ----------------------------------------------------------------------------- 637 638sub test_roundtrip { 639 my ($file,%named_args) = @_; 640 641 &report_skip ("file $file does not exist") unless -r $file; 642 643 my $format = $named_args{'format'}; 644 my $newext = $named_args{'ext'}; 645 my $resize = $named_args{'resize'}; 646 my $ignore_failure = $named_args{'ignore_failure'}; 647 648 my $filter0 = &normalize_filter ($named_args{'filter0'}); 649 my $filter1 = &normalize_filter ($named_args{'filter1'} || 650 $named_args{'filter'}); 651 my $filter2 = &normalize_filter ($named_args{'filter2'} || 652 $named_args{'filter'}); 653 654 my $tmp = fileparse ($file); 655 $tmp =~ s/\.([a-zA-Z0-9]+)$// or die "Must have extension for roundtrip test."; 656 my $ext = $1; 657 my $code; 658 my $keep = 0; 659 660 my $file_resized = $file; 661 if ($resize) { 662 $file_resized =~ s{^.*/}{}; 663 $file_resized =~ s/(\.gnumeric)$/-resize$1/; 664 unlink $file_resized; 665 my $cmd = "earg ($ssconvert, "--resize", $resize, $file, $file_resized); 666 print STDERR "# $cmd\n" if $verbose; 667 $code = system ("$cmd 2>&1 | sed -e 's/^/| /'"); 668 &system_failure ($ssconvert, $code) if $code; 669 die "Failed to produce $file_resized\n" unless -r $file_resized; 670 &junkfile ($file_resized) unless $keep; 671 } 672 673 my $file_filtered = $file_resized; 674 if ($filter0) { 675 $file_filtered =~ s{^.*/}{}; 676 $file_filtered =~ s/(\.gnumeric)$/-filter$1/; 677 unlink $file_filtered; 678 my $cmd = "zcat " . "earg ($file_resized) . " | $filter0 >" . "earg ($file_filtered); 679 print STDERR "# $cmd\n" if $verbose; 680 $code = system ("($cmd) 2>&1 | sed -e 's/^/| /'"); 681 &system_failure ($ssconvert, $code) if $code; 682 die "Failed to produce $file_filtered\n" unless -r $file_filtered; 683 &junkfile ($file_filtered) unless $keep; 684 } 685 686 my $tmp1 = "$tmp.$newext"; 687 unlink $tmp1; 688 &junkfile ($tmp1) unless $keep; 689 { 690 my $cmd = "earg ($ssconvert, "-T", $format, $file_filtered, $tmp1); 691 print "# $cmd\n" if $verbose; 692 my $code = system ("$cmd 2>&1 | sed -e 's/^/| /'"); 693 &system_failure ($ssconvert, $code) if $code; 694 die "Failed to produce $tmp1\n" unless -r $tmp1; 695 } 696 697 my $tmp2 = "$tmp-new.$ext"; 698 unlink $tmp2; 699 &junkfile ($tmp2) unless $keep; 700 { 701 my $cmd = "earg ($ssconvert, $tmp1, $tmp2); 702 print "# $cmd\n" if $verbose; 703 my $code = system ("$cmd 2>&1 | sed -e 's/^/| /'"); 704 &system_failure ($ssconvert, $code) if $code; 705 die "Failed to produce $tmp2\n" unless -r $tmp2; 706 } 707 708 my $tmp_xml = "$tmp.xml"; 709 unlink $tmp_xml; 710 &junkfile ($tmp_xml) unless $keep; 711 $code = system ("zcat -f '$file_filtered' | $normalize_gnumeric | $filter1 >'$tmp_xml'"); 712 &system_failure ('zcat', $code) if $code; 713 714 my $tmp2_xml = "$tmp-new.xml"; 715 unlink $tmp2_xml; 716 &junkfile ($tmp2_xml) unless $keep; 717 # print STDERR "zcat -f '$tmp2' | $normalize_gnumeric | $filter2 >'$tmp2_xml'\n"; 718 $code = system ("zcat -f '$tmp2' | $normalize_gnumeric | $filter2 >'$tmp2_xml'"); 719 &system_failure ('zcat', $code) if $code; 720 721 $code = system ('diff', '-u', $tmp_xml, $tmp2_xml); 722 &system_failure ('diff', $code) if $code && !$ignore_failure; 723 724 print STDERR "Pass\n"; 725} 726 727# ----------------------------------------------------------------------------- 728 729sub test_valgrind { 730 my ($cmd,$uselibtool,$qreturn) = @_; 731 732 local (%ENV) = %ENV; 733 $ENV{'G_DEBUG'} .= ':gc-friendly:resident-modules'; 734 $ENV{'G_SLICE'} = 'always-malloc'; 735 $ENV{'PYTHONMALLOC'} = 'malloc'; 736 delete $ENV{'VALGRIND_OPTS'}; 737 738 my $outfile = 'valgrind.log'; 739 unlink $outfile; 740 die "Cannot remove $outfile.\n" if -f $outfile; 741 &junkfile ($outfile); 742 743 my $valhelp = `valgrind --help 2>&1`; 744 &report_skip ("Valgrind is not available") unless defined $valhelp; 745 die "Problem running valgrind.\n" unless $valhelp =~ /log-file/; 746 747 my $valvers = `valgrind --version`; 748 die "Problem running valgrind.\n" 749 unless $valvers =~ /^valgrind-(\d+)\.(\d+)\.(\d+)/; 750 $valvers = $1 * 10000 + $2 * 100 + $3; 751 &report_skip ("Valgrind is too old") unless $valvers >= 30500; 752 753 $cmd = "--gen-suppressions=all $cmd"; 754 755 { 756 my $suppfile = "$topsrc/test/common.supp"; 757 &report_skip ("file $suppfile does not exist") unless -r $suppfile; 758 $cmd = "--suppressions=$suppfile $cmd" if -r $suppfile; 759 } 760 761 { 762 my $suppfile = $0; 763 $suppfile =~ s/\.pl$/.supp/; 764 $cmd = "--suppressions=$suppfile $cmd" if -r $suppfile; 765 } 766 767 # $cmd = "--show-reachable=yes $cmd"; 768 $cmd = "--show-below-main=yes $cmd"; 769 $cmd = "--leak-check=full $cmd"; 770 $cmd = "--num-callers=20 $cmd"; 771 $cmd = "--track-fds=yes $cmd"; 772 if ($valhelp =~ /--log-file-exactly=/) { 773 $cmd = "--log-file-exactly=$outfile $cmd"; 774 } else { 775 $cmd = "--log-file=$outfile $cmd"; 776 } 777 $cmd = "valgrind $cmd"; 778 $cmd = "../libtool --mode=execute $cmd" if $uselibtool; 779 780 my $code = system ($cmd); 781 &system_failure ('valgrind', $code) if $code; 782 783 my $txt = &read_file ($outfile); 784 &removejunk ($outfile); 785 my $errors = ($txt =~ /ERROR\s+SUMMARY:\s*(\d+)\s+errors?/i) 786 ? $1 787 : -1; 788 if ($errors == 0) { 789 # &dump_indented ($txt); 790 print STDERR "Pass\n" unless $qreturn; 791 return 0; 792 } 793 794 &dump_indented ($txt); 795 die "Fail\n" unless $qreturn; 796 return 1; 797} 798 799# ----------------------------------------------------------------------------- 800 801sub test_ssindex { 802 my ($file,$test) = @_; 803 804 &report_skip ("file $file does not exist") unless -r $file; 805 806 my $xmlfile = fileparse ($file); 807 $xmlfile =~ s/\.[a-zA-Z0-9]+$/.xml/; 808 unlink $xmlfile; 809 die "Cannot remove $xmlfile.\n" if -f $xmlfile; 810 &junkfile ($xmlfile); 811 812 { 813 my $cmd = "earg ($ssindex, "--index", $file); 814 print STDERR "# $cmd\n" if $verbose; 815 my $output = `$cmd 2>&1 >'$xmlfile'`; 816 my $err = $?; 817 &dump_indented ($output); 818 die "Failed command: $cmd\n" if $err; 819 } 820 821 my $parser = new XML::Parser ('Style' => 'Tree'); 822 my $tree = $parser->parsefile ($xmlfile); 823 &removejunk ($xmlfile); 824 825 my @items; 826 827 die "$0: Invalid parse tree from ssindex.\n" 828 unless (ref ($tree) eq 'ARRAY' && $tree->[0] eq "gnumeric"); 829 my @children = @{$tree->[1]}; 830 my $attrs = shift @children; 831 832 while (@children) { 833 my $tag = shift @children; 834 my $content = shift @children; 835 836 if ($tag eq '0') { 837 # A text node 838 goto FAIL unless $content =~ /^\s*$/; 839 } elsif ($tag eq 'data') { 840 my @dchildren = @$content; 841 my $dattrs = shift @dchildren; 842 die "$0: Unexpected attributes in data tag\n" if keys %$dattrs; 843 die "$0: Unexpected data tag content.\n" if @dchildren != 2; 844 die "$0: Unexpected data tag content.\n" if $dchildren[0] ne '0'; 845 my $data = $dchildren[1]; 846 push @items, $data; 847 } else { 848 die "$0: Unexpected tag \"$tag\".\n"; 849 } 850 } 851 852 local $_ = \@items; 853 if (&$test ($_)) { 854 print STDERR "Pass\n"; 855 } else { 856 FAIL: 857 die "Fail\n"; 858 } 859} 860 861# ----------------------------------------------------------------------------- 862 863sub test_tool { 864 my ($file,$tool,$tool_args,$range,$test) = @_; 865 866 &report_skip ("file $file does not exist") unless -r $file; 867 868 my @args; 869 push @args, "--export-range=$range" if defined $range; 870 push @args, "--tool-test=$tool"; 871 for (my $i = 0; $i + 1 < @$tool_args; $i += 2) { 872 my $k = $tool_args->[$i]; 873 my $v = $tool_args->[$i + 1]; 874 push @args, "--tool-test=$k:$v"; 875 } 876 877 my $tmp = "tool.csv"; 878 &junkfile ($tmp); 879 880 my $cmd = "earg ($ssconvert, @args, $file, $tmp); 881 print STDERR "# $cmd\n" if $GnumericTest::verbose; 882 my $code = system ($cmd); 883 &system_failure ($ssconvert, $code) if $code; 884 my $actual = &read_file ($tmp); 885 886 &removejunk ($tmp); 887 888 if (&$test ($actual)) { 889 print STDERR "Pass\n"; 890 } else { 891 &GnumericTest::dump_indented ($actual); 892 die "Fail\n"; 893 } 894} 895 896# ----------------------------------------------------------------------------- 897 898sub has_linear_solver { 899 return (defined (&find_program ('lp_solve', 1)) || 900 defined (&find_program ('glpsol', 1))); 901} 902 903# ----------------------------------------------------------------------------- 904 905sub make_absolute { 906 my ($fn) = @_; 907 908 return $fn if $fn =~ m{^/}; 909 $fn =~ s{^\./+([^/])}{$1}; 910 my $pwd = $ENV{'PWD'}; 911 $pwd .= '/' unless $pwd =~ m{/$}; 912 return "$pwd$fn"; 913} 914 915# ----------------------------------------------------------------------------- 916 917sub setup_python_environment { 918 $PYTHON = `grep '^#define PYTHON_INTERPRETER ' $top_builddir/gnumeric-config.h 2>&1`; 919 chomp $PYTHON; 920 $PYTHON =~ s/^[^"]*"(.*)"\s*$/$1/; 921 &report_skip ("Missing python interpreter") unless -x $PYTHON; 922 923 # Make sure we load introspection preferentially from build directory 924 my $v = 'GI_TYPELIB_PATH'; 925 my $dir = "$top_builddir/src"; 926 $ENV{$v} = ($ENV{$v} || '') eq '' ? $dir : $dir . ':' . $ENV{$v}; 927 928 # Ditto for shared libraries 929 $v = 'LD_LIBRARY_PATH'; 930 $dir = "$top_builddir/src/.libs"; 931 $ENV{$v} = ($ENV{$v} || '') eq '' ? $dir : $dir . ':' . $ENV{$v}; 932 933 $ENV{'GNM_TEST_INTROSPECTION_DIR'} = &make_absolute ("$topsrc/introspection/gi/overrides"); 934 935 # Don't litter 936 $ENV{'PYTHONDONTWRITEBYTECODE'} = 1; 937 938 $0 = &make_absolute ($0); 939 $ENV{'GNM_TEST_TOP_BUILDDIR'} = $top_builddir; 940} 941 942# ----------------------------------------------------------------------------- 943 944sub quotearg { 945 return join (' ', map { "earg1 ($_) } @_); 946} 947 948sub quotearg1 { 949 my ($arg) = @_; 950 951 return "''" if $arg eq ''; 952 my $res = ''; 953 while ($arg ne '') { 954 if ($arg =~ m!^([-=/._a-zA-Z0-9:]+)!) { 955 $res .= $1; 956 $arg = substr ($arg, length $1); 957 } else { 958 $res .= "\\" . substr ($arg, 0, 1); 959 $arg = substr ($arg, 1); 960 } 961 } 962 return $res; 963} 964 965# ----------------------------------------------------------------------------- 966 967sub report_skip { 968 my ($txt) = @_; 969 970 print "SKIP -- $txt\n"; 971 # 77 is magic for automake 972 exit 77; 973} 974 975# ----------------------------------------------------------------------------- 976# Setup a consistent environment 977 978&report_skip ("all tests skipped") if exists $ENV{'GNUMERIC_SKIP_TESTS'}; 979 980delete $ENV{'G_SLICE'}; 981$ENV{'G_DEBUG'} = 'fatal_criticals'; 982 983delete $ENV{'LANG'}; 984delete $ENV{'LANGUAGE'}; 985foreach (keys %ENV) { delete $ENV{$_} if /^LC_/; } 986$ENV{'LC_ALL'} = 'C'; 987 988# libgsf listens for this 989delete $ENV{'WINDOWS_LANGUAGE'}; 990 991my $seed = time(); 992 993while (1) { 994 if (@ARGV && $ARGV[0] eq '--verbose') { 995 $verbose = 1; 996 scalar shift @ARGV; 997 next; 998 } elsif (@ARGV > 1 && $ARGV[0] eq '--subtests') { 999 scalar shift @ARGV; 1000 $subtests = shift @ARGV; 1001 } elsif (@ARGV > 1 && $ARGV[0] eq '--corpus') { 1002 scalar shift @ARGV; 1003 $user_corpus = shift @ARGV; 1004 } else { 1005 last; 1006 } 1007} 1008 1009srand ($seed); 1010 10111; 1012