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