test/GnumericTest.pm

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